diff --git a/m4/ax_mexopts.m4 b/m4/ax_mexopts.m4 index c0fbd1145..e6ccd40c5 100644 --- a/m4/ax_mexopts.m4 +++ b/m4/ax_mexopts.m4 @@ -33,6 +33,7 @@ case ${MATLAB_ARCH} in MATLAB_DEFS="$MATLAB_DEFS -D_GNU_SOURCE -DNDEBUG" MATLAB_CFLAGS="-ansi -fexceptions -fPIC -pthread -g -O2" MATLAB_CXXFLAGS="-ansi -fPIC -pthread -g -O2" + MATLAB_FFLAGS="-fPIC -g -O2 -fexceptions" MATLAB_LDFLAGS="-shared -Wl,--version-script,$MATLAB/extern/lib/${MATLAB_ARCH}/mexFunction.map -Wl,--no-undefined -Wl,-rpath-link,$MATLAB/bin/${MATLAB_ARCH} -L$MATLAB/bin/${MATLAB_ARCH}" MATLAB_LIBS="-lmx -lmex -lmat -lm -lstdc++ -lmwlapack" # Starting from MATLAB 7.5, BLAS and LAPACK are in distinct libraries @@ -50,6 +51,7 @@ case ${MATLAB_ARCH} in win32 | win64) MATLAB_CFLAGS="-fexceptions -g -O2" MATLAB_CXXFLAGS="-g -O2" + MATLAB_FFLAGS="-fexceptions -g -O2" AX_COMPARE_VERSION([$MATLAB_VERSION], [eq], [7.0.1], [AC_MSG_ERROR([MATLAB version 7.0.1 (R14SP1) is buggy (LAPACK library missing for MSVC), and can't be used for compiling MEX files])]) MATLAB_DEFS="$MATLAB_DEFS -DNDEBUG" # Note that static-libstdc++ is only supported since GCC 4.5 (but generates no error on older versions) @@ -72,6 +74,7 @@ case ${MATLAB_ARCH} in MATLAB_LDFLAGS="-L$MATLAB/bin/${MATLAB_ARCH} -Wl,-twolevel_namespace -undefined error -arch $ARCHS -Wl,-syslibroot,$SDKROOT -mmacosx-version-min=$MACOSX_DEPLOYMENT_TARGET -bundle -Wl,-exported_symbols_list,\$(top_srcdir)/mexFunction-MacOSX.map" MATLAB_LIBS="-lmx -lmex -lmat -lstdc++ -lmwlapack" MATLAB_CXXFLAGS="-fno-common -no-cpp-precomp -fexceptions -arch $ARCHS -isysroot $SDKROOT -mmacosx-version-min=$MACOSX_DEPLOYMENT_TARGET -O2" + MATLAB_CXXFLAGS="-fexceptions -fbackslash -g -O2" # Starting from MATLAB 7.5, BLAS and LAPACK are in distinct libraries AX_COMPARE_VERSION([$MATLAB_VERSION], [ge], [7.5], [MATLAB_LIBS="${MATLAB_LIBS} -lmwblas"]) ax_mexopts_ok="yes" diff --git a/mex/build/libslicot.am b/mex/build/libslicot.am new file mode 100644 index 000000000..295d931dd --- /dev/null +++ b/mex/build/libslicot.am @@ -0,0 +1,484 @@ +vpath %.f $(top_srcdir)/../../sources/libslicot + +noinst_LIBRARIES = libslicot.a libauxslicot.a + +SLICOT_SRC = \ + AB01MD.f \ + AB01ND.f \ + AB01OD.f \ + AB04MD.f \ + AB05MD.f \ + AB05ND.f \ + AB05OD.f \ + AB05PD.f \ + AB05QD.f \ + AB05RD.f \ + AB05SD.f \ + AB07MD.f \ + AB07ND.f \ + AB08MD.f \ + AB08MZ.f \ + AB08ND.f \ + AB08NX.f \ + AB08NZ.f \ + AB09AD.f \ + AB09AX.f \ + AB09BD.f \ + AB09BX.f \ + AB09CD.f \ + AB09CX.f \ + AB09DD.f \ + AB09ED.f \ + AB09FD.f \ + AB09GD.f \ + AB09HD.f \ + AB09HX.f \ + AB09HY.f \ + AB09ID.f \ + AB09IX.f \ + AB09IY.f \ + AB09JD.f \ + AB09JV.f \ + AB09JW.f \ + AB09JX.f \ + AB09KD.f \ + AB09KX.f \ + AB09MD.f \ + AB09ND.f \ + AB13AD.f \ + AB13AX.f \ + AB13BD.f \ + AB13CD.f \ + AB13DD.f \ + AB13DX.f \ + AB13ED.f \ + AB13FD.f \ + AB13MD.f \ + AB8NXZ.f \ + AG07BD.f \ + AG08BD.f \ + AG08BY.f \ + AG08BZ.f \ + AG8BYZ.f \ + BB01AD.f \ + BB02AD.f \ + BB03AD.f \ + BB04AD.f \ + BD01AD.f \ + BD02AD.f \ + DE01OD.f \ + DE01PD.f \ + delctg.f \ + DF01MD.f \ + DG01MD.f \ + DG01ND.f \ + DG01NY.f \ + DG01OD.f \ + DK01MD.f \ + FB01QD.f \ + FB01RD.f \ + FB01SD.f \ + FB01TD.f \ + FB01VD.f \ + FD01AD.f \ + IB01AD.f \ + IB01BD.f \ + IB01CD.f \ + IB01MD.f \ + IB01MY.f \ + IB01ND.f \ + IB01OD.f \ + IB01OY.f \ + IB01PD.f \ + IB01PX.f \ + IB01PY.f \ + IB01QD.f \ + IB01RD.f \ + IB03AD.f \ + IB03BD.f \ + MA01AD.f \ + MA02AD.f \ + MA02BD.f \ + MA02BZ.f \ + MA02CD.f \ + MA02CZ.f \ + MA02DD.f \ + MA02ED.f \ + MA02FD.f \ + MA02GD.f \ + MA02HD.f \ + MA02ID.f \ + MA02JD.f \ + MB01MD.f \ + MB01ND.f \ + MB01PD.f \ + MB01QD.f \ + MB01RD.f \ + MB01RU.f \ + MB01RW.f \ + MB01RX.f \ + MB01RY.f \ + MB01SD.f \ + MB01TD.f \ + MB01UD.f \ + MB01UW.f \ + MB01UX.f \ + MB01VD.f \ + MB01WD.f \ + MB01XD.f \ + MB01XY.f \ + MB01YD.f \ + MB01ZD.f \ + MB02CD.f \ + MB02CU.f \ + MB02CV.f \ + MB02CX.f \ + MB02CY.f \ + MB02DD.f \ + MB02ED.f \ + MB02FD.f \ + MB02GD.f \ + MB02HD.f \ + MB02ID.f \ + MB02JD.f \ + MB02JX.f \ + MB02KD.f \ + MB02MD.f \ + MB02ND.f \ + MB02NY.f \ + MB02OD.f \ + MB02PD.f \ + MB02QD.f \ + MB02QY.f \ + MB02RD.f \ + MB02RZ.f \ + MB02SD.f \ + MB02SZ.f \ + MB02TD.f \ + MB02TZ.f \ + MB02UD.f \ + MB02UU.f \ + MB02UV.f \ + MB02VD.f \ + MB02WD.f \ + MB02XD.f \ + MB02YD.f \ + MB03MD.f \ + MB03MY.f \ + MB03ND.f \ + MB03NY.f \ + MB03OD.f \ + MB03OY.f \ + MB03PD.f \ + MB03PY.f \ + MB03QD.f \ + MB03QX.f \ + MB03QY.f \ + MB03RD.f \ + MB03RX.f \ + MB03RY.f \ + MB03SD.f \ + MB03TD.f \ + MB03TS.f \ + MB03UD.f \ + MB03VD.f \ + MB03VY.f \ + MB03WA.f \ + MB03WD.f \ + MB03WX.f \ + MB03XD.f \ + MB03XP.f \ + MB03XU.f \ + MB03YA.f \ + MB03YD.f \ + MB03YT.f \ + MB03ZA.f \ + MB03ZD.f \ + MB04DD.f \ + MB04DI.f \ + MB04DS.f \ + MB04DY.f \ + MB04GD.f \ + MB04ID.f \ + MB04IY.f \ + MB04IZ.f \ + MB04JD.f \ + MB04KD.f \ + MB04LD.f \ + MB04MD.f \ + MB04ND.f \ + MB04NY.f \ + MB04OD.f \ + MB04OW.f \ + MB04OX.f \ + MB04OY.f \ + MB04PA.f \ + MB04PB.f \ + MB04PU.f \ + MB04PY.f \ + MB04QB.f \ + MB04QC.f \ + MB04QF.f \ + MB04QU.f \ + MB04TB.f \ + MB04TS.f \ + MB04TT.f \ + MB04TU.f \ + MB04TV.f \ + MB04TW.f \ + MB04TX.f \ + MB04TY.f \ + MB04UD.f \ + MB04VD.f \ + MB04VX.f \ + MB04WD.f \ + MB04WP.f \ + MB04WR.f \ + MB04WU.f \ + MB04XD.f \ + MB04XY.f \ + MB04YD.f \ + MB04YW.f \ + MB04ZD.f \ + MB05MD.f \ + MB05MY.f \ + MB05ND.f \ + MB05OD.f \ + MB05OY.f \ + MB3OYZ.f \ + MB3PYZ.f \ + MC01MD.f \ + MC01ND.f \ + MC01OD.f \ + MC01PD.f \ + MC01PY.f \ + MC01QD.f \ + MC01RD.f \ + MC01SD.f \ + MC01SW.f \ + MC01SX.f \ + MC01SY.f \ + MC01TD.f \ + MC01VD.f \ + MC01WD.f \ + MC03MD.f \ + MC03ND.f \ + MC03NX.f \ + MC03NY.f \ + MD03AD.f \ + MD03BA.f \ + MD03BB.f \ + MD03BD.f \ + MD03BF.f \ + MD03BX.f \ + MD03BY.f \ + NF01AD.f \ + NF01AY.f \ + NF01BA.f \ + NF01BB.f \ + NF01BD.f \ + NF01BE.f \ + NF01BF.f \ + NF01BP.f \ + NF01BQ.f \ + NF01BR.f \ + NF01BS.f \ + NF01BU.f \ + NF01BV.f \ + NF01BW.f \ + NF01BX.f \ + NF01BY.f \ + SB01BD.f \ + SB01BX.f \ + SB01BY.f \ + SB01DD.f \ + SB01FY.f \ + SB01MD.f \ + SB02CX.f \ + SB02MD.f \ + SB02MR.f \ + SB02MS.f \ + SB02MT.f \ + SB02MU.f \ + SB02MV.f \ + SB02MW.f \ + SB02ND.f \ + SB02OD.f \ + SB02OU.f \ + SB02OV.f \ + SB02OW.f \ + SB02OX.f \ + SB02OY.f \ + SB02PD.f \ + SB02QD.f \ + SB02RD.f \ + SB02RU.f \ + SB02SD.f \ + SB03MD.f \ + SB03MU.f \ + SB03MV.f \ + SB03MW.f \ + SB03MX.f \ + SB03MY.f \ + SB03OD.f \ + SB03OR.f \ + SB03OT.f \ + SB03OU.f \ + SB03OV.f \ + SB03OY.f \ + SB03PD.f \ + SB03QD.f \ + SB03QX.f \ + SB03QY.f \ + SB03RD.f \ + SB03SD.f \ + SB03SX.f \ + SB03SY.f \ + SB03TD.f \ + SB03UD.f \ + SB04MD.f \ + SB04MR.f \ + SB04MU.f \ + SB04MW.f \ + SB04MY.f \ + SB04ND.f \ + SB04NV.f \ + SB04NW.f \ + SB04NX.f \ + SB04NY.f \ + SB04OD.f \ + SB04OW.f \ + SB04PD.f \ + SB04PX.f \ + SB04PY.f \ + SB04QD.f \ + SB04QR.f \ + SB04QU.f \ + SB04QY.f \ + SB04RD.f \ + SB04RV.f \ + SB04RW.f \ + SB04RX.f \ + SB04RY.f \ + SB06ND.f \ + SB08CD.f \ + SB08DD.f \ + SB08ED.f \ + SB08FD.f \ + SB08GD.f \ + SB08HD.f \ + SB08MD.f \ + SB08MY.f \ + SB08ND.f \ + SB08NY.f \ + SB09MD.f \ + SB10AD.f \ + SB10DD.f \ + SB10ED.f \ + SB10FD.f \ + SB10HD.f \ + SB10ID.f \ + SB10JD.f \ + SB10KD.f \ + SB10LD.f \ + SB10MD.f \ + SB10PD.f \ + SB10QD.f \ + SB10RD.f \ + SB10SD.f \ + SB10TD.f \ + SB10UD.f \ + SB10VD.f \ + SB10WD.f \ + SB10YD.f \ + SB10ZD.f \ + SB10ZP.f \ + SB16AD.f \ + SB16AY.f \ + SB16BD.f \ + SB16CD.f \ + SB16CY.f \ + select.f \ + SG02AD.f \ + SG03AD.f \ + SG03AX.f \ + SG03AY.f \ + SG03BD.f \ + SG03BU.f \ + SG03BV.f \ + SG03BW.f \ + SG03BX.f \ + SG03BY.f \ + TB01ID.f \ + TB01IZ.f \ + TB01KD.f \ + TB01LD.f \ + TB01MD.f \ + TB01ND.f \ + TB01PD.f \ + TB01TD.f \ + TB01TY.f \ + TB01UD.f \ + TB01VD.f \ + TB01VY.f \ + TB01WD.f \ + TB01XD.f \ + TB01XZ.f \ + TB01YD.f \ + TB01ZD.f \ + TB03AD.f \ + TB03AY.f \ + TB04AD.f \ + TB04AY.f \ + TB04BD.f \ + TB04BV.f \ + TB04BW.f \ + TB04BX.f \ + TB04CD.f \ + TB05AD.f \ + TC01OD.f \ + TC04AD.f \ + TC05AD.f \ + TD03AD.f \ + TD03AY.f \ + TD04AD.f \ + TD05AD.f \ + TF01MD.f \ + TF01MX.f \ + TF01MY.f \ + TF01ND.f \ + TF01OD.f \ + TF01PD.f \ + TF01QD.f \ + TF01RD.f \ + TG01AD.f \ + TG01AZ.f \ + TG01BD.f \ + TG01CD.f \ + TG01DD.f \ + TG01ED.f \ + TG01FD.f \ + TG01FZ.f \ + TG01HD.f \ + TG01HX.f \ + TG01ID.f \ + TG01JD.f \ + TG01WD.f \ + UD01BD.f \ + UD01CD.f \ + UD01DD.f \ + UD01MD.f \ + UD01MZ.f \ + UD01ND.f \ + UE01MD.f + +SLICOT_AUX = \ + dcabs1.f \ + dhgeqz.f \ + dtgsy2.f + +nodist_libslicot_a_SOURCES = \ + $(SLICOT_SRC) + +nodist_libauxslicot_a_SOURCES = \ + $(SLICOT_AUX) \ No newline at end of file diff --git a/mex/build/matlab/Makefile.am b/mex/build/matlab/Makefile.am index 3a4bd041f..f63264b81 100644 --- a/mex/build/matlab/Makefile.am +++ b/mex/build/matlab/Makefile.am @@ -2,7 +2,7 @@ ACLOCAL_AMFLAGS = -I ../../../m4 # libdynare++ must come before gensylv, k_order_perturbation, dynare_simul_ if DO_SOMETHING -SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior +SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior libslicot if HAVE_GSL SUBDIRS += swz endif diff --git a/mex/build/matlab/configure.ac b/mex/build/matlab/configure.ac index 2008a8d08..ad3795b77 100644 --- a/mex/build/matlab/configure.ac +++ b/mex/build/matlab/configure.ac @@ -38,6 +38,7 @@ if test "x$ax_enable_matlab" = "xyes"; then CFLAGS="$MATLAB_CFLAGS" CXXFLAGS="$MATLAB_CXXFLAGS" + FFLAGS="$MATLAB_FFLAGS" fi case ${host_os} in @@ -49,8 +50,10 @@ case ${host_os} in esac CFLAGS="$CFLAGS -Wall" +FFLAGS="$FFLAGS -Wall" CXXFLAGS="$CXXFLAGS -Wall" +AC_PROG_F77 AC_PROG_CC AC_PROG_CXX AC_PROG_RANLIB @@ -130,6 +133,7 @@ AC_CONFIG_FILES([Makefile dynare_simul_/Makefile swz/Makefile logposterior/Makefile - logMHMCMCposterior/Makefile]) + logMHMCMCposterior/Makefile + libslicot/Makefile]) AC_OUTPUT diff --git a/mex/build/matlab/libslicot/Makefile.am b/mex/build/matlab/libslicot/Makefile.am new file mode 100644 index 000000000..680519fea --- /dev/null +++ b/mex/build/matlab/libslicot/Makefile.am @@ -0,0 +1,2 @@ +include ../mex.am +include ../../libslicot.am diff --git a/mex/build/octave/Makefile.am b/mex/build/octave/Makefile.am index ebbc7e7c9..09a31661b 100644 --- a/mex/build/octave/Makefile.am +++ b/mex/build/octave/Makefile.am @@ -2,7 +2,7 @@ ACLOCAL_AMFLAGS = -I ../../../m4 # libdynare++ must come before gensylv, k_order_perturbation, dynare_simul_ if DO_SOMETHING -SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior qzcomplex ordschur +SUBDIRS = mjdgges kronecker bytecode libdynare++ gensylv k_order_perturbation dynare_simul_ logposterior logMHMCMCposterior qzcomplex ordschur libslicot if HAVE_GSL SUBDIRS += swz endif diff --git a/mex/build/octave/configure.ac b/mex/build/octave/configure.ac index 3b3177740..d41de1e3f 100644 --- a/mex/build/octave/configure.ac +++ b/mex/build/octave/configure.ac @@ -28,12 +28,15 @@ if test "x$MKOCTFILE" != "x"; then CC=`$MKOCTFILE -p CC` CXX=`$MKOCTFILE -p CXX` CFLAGS=`$MKOCTFILE -p CFLAGS` + FFLAGS=`$MKOCTFILE -p FFLAGS` CXXFLAGS=`$MKOCTFILE -p CXXFLAGS` fi CFLAGS="$CFLAGS -Wall" +FFLAGS="$FFLAGS -Wall" CXXFLAGS="$CXXFLAGS -Wall" +AC_PROG_F77 AC_PROG_CC AC_PROG_CXX AC_PROG_RANLIB @@ -104,6 +107,7 @@ AC_CONFIG_FILES([Makefile logposterior/Makefile logMHMCMCposterior/Makefile qzcomplex/Makefile - ordschur/Makefile]) + ordschur/Makefile + libslicot/Makefile]) AC_OUTPUT diff --git a/mex/build/octave/libslicot/Makefile.am b/mex/build/octave/libslicot/Makefile.am new file mode 100644 index 000000000..47b05ecff --- /dev/null +++ b/mex/build/octave/libslicot/Makefile.am @@ -0,0 +1,3 @@ +EXEEXT = .mex +include ../mex.am +include ../../libslicot.am diff --git a/mex/sources/libslicot/AB01MD.f b/mex/sources/libslicot/AB01MD.f new file mode 100644 index 000000000..d00d02a82 --- /dev/null +++ b/mex/sources/libslicot/AB01MD.f @@ -0,0 +1,402 @@ + SUBROUTINE AB01MD( JOBZ, N, A, LDA, B, NCONT, Z, LDZ, TAU, TOL, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a controllable realization for the linear time-invariant +C single-input system +C +C dX/dt = A * X + B * U, +C +C where A is an N-by-N matrix and B is an N element vector which +C are reduced by this routine to orthogonal canonical form using +C (and optionally accumulating) orthogonal similarity +C transformations. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal similarity transformations for +C reducing the system, as follows: +C = 'N': Do not form Z and do not store the orthogonal +C transformations; +C = 'F': Do not form Z, but store the orthogonal +C transformations in the factored form; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NCONT-by-NCONT upper Hessenberg +C part of this array contains the canonical form of the +C state dynamics matrix, given by Z' * A * Z, of a +C controllable realization for the original system. The +C elements below the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, the original input/state vector B. +C On exit, the leading NCONT elements of this array contain +C canonical form of the input/state vector, given by Z' * B, +C with all elements but B(1) set to zero. +C +C NCONT (output) INTEGER +C The order of the controllable state-space representation. +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C If JOBZ = 'I', then the leading N-by-N part of this array +C contains the matrix of accumulated orthogonal similarity +C transformations which reduces the given system to +C orthogonal canonical form. +C If JOBZ = 'F', the elements below the diagonal, with the +C array TAU, represent the orthogonal transformation matrix +C as a product of elementary reflectors. The transformation +C matrix can then be obtained by calling the LAPACK Library +C routine DORGQR. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'I' or +C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The elements of TAU contain the scalar factors of the +C elementary reflectors used in the reduction of B and A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the +C controllability of (A,B). If the user sets TOL > 0, then +C the given value of TOL is used as an absolute tolerance; +C elements with absolute value less than TOL are considered +C neglijible. If the user sets TOL <= 0, then an implicitly +C computed, default tolerance, defined by +C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Householder matrix which reduces all but the first element +C of vector B to zero is found and this orthogonal similarity +C transformation is applied to the matrix A. The resulting A is then +C reduced to upper Hessenberg form by a sequence of Householder +C transformations. Finally, the order of the controllable state- +C space representation (NCONT) is determined by finding the position +C of the first sub-diagonal element of A which is below an +C appropriate zero threshold, either TOL or TOLDEF (see parameter +C TOL); if NORM(B) is smaller than this threshold, NCONT is set to +C zero, and no computations for reducing the system to orthogonal +C canonical form are performed. +C +C REFERENCES +C +C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. +C Orthogonal Invariants and Canonical Forms for Linear +C Controllable Systems. +C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. +C +C [2] Hammarling, S.J. +C Notes on the use of orthogonal similarity transformations in +C control. +C NPL Report DITC 8/82, August 1982. +C +C [3] Paige, C.C +C Properties of numerical algorithms related to computing +C controllability. +C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. +C Supersedes Release 2.0 routine AB01AD by T.W.C. Williams, +C Kingston Polytechnic, United Kingdom, October 1982. +C +C REVISIONS +C +C V. Sima, February 16, 1998, October 19, 2001, February 2, 2005. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDA, LDZ, LDWORK, N, NCONT + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), TAU(*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL LJOBF, LJOBI, LJOBZ + INTEGER ITAU, J + DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, + $ TOLDEF, WRKOPT +C .. Local Arrays .. + DOUBLE PRECISION NBLK(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, + $ MB01PD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBF = LSAME( JOBZ, 'F' ) + LJOBI = LSAME( JOBZ, 'I' ) + LJOBZ = LJOBF.OR.LJOBI +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX(1,N) ) THEN + INFO = -4 + ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. + $ LJOBZ .AND. LDZ.LT.MAX(1,N) ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB01MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NCONT = 0 + DWORK(1) = ONE + IF ( N.EQ.0 ) + $ RETURN +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = ONE +C +C Calculate the absolute norms of A and B (used for scaling). +C + ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) + BNORM = DLANGE( 'M', N, 1, B, N, DWORK ) +C +C Return if matrix B is zero. +C + IF( BNORM.EQ.ZERO ) THEN + IF( LJOBF ) THEN + CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) + ELSE IF( LJOBI ) THEN + CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) + END IF + RETURN + END IF +C +C Scale (if needed) the matrices A and B. +C + CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) + CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) +C +C Calculate the Frobenius norm of A and the 1-norm of B (used for +C controlability test). +C + FANORM = DLANGE( 'F', N, N, A, LDA, DWORK ) + FBNORM = DLANGE( '1', N, 1, B, N, DWORK ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) + TOLDEF = THRESH*MAX( FANORM, FBNORM ) + END IF +C + ITAU = 1 + IF ( FBNORM.GT.TOLDEF ) THEN +C +C B is not negligible compared with A. +C + IF ( N.GT.1 ) THEN +C +C Transform B by a Householder matrix Z1: store vector +C describing this temporarily in B and in the local scalar H. +C + CALL DLARFG( N, B(1), B(2), 1, H ) +C + B1 = B(1) + B(1) = ONE +C +C Form Z1 * A * Z1. +C + CALL DLARF( 'R', N, N, B, 1, H, A, LDA, DWORK ) + CALL DLARF( 'L', N, N, B, 1, H, A, LDA, DWORK ) +C + B(1) = B1 + TAU(1) = H + ITAU = ITAU + 1 + ELSE + B1 = B(1) + END IF +C +C Reduce modified A to upper Hessenberg form by an orthogonal +C similarity transformation with matrix Z2. +C Workspace: need N; prefer N*NB. +C + CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) + WRKOPT = DWORK(1) +C + IF ( LJOBZ ) THEN +C +C Save the orthogonal transformations used, so that they could +C be accumulated by calling DORGQR routine. +C + IF ( N.GT.1 ) + $ CALL DLACPY( 'F', N-1, 1, B(2), N-1, Z(2,1), LDZ ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'L', N-2, N-2, A(3,1), LDA, Z(3,2), LDZ ) + IF ( LJOBI ) THEN +C +C Form the orthogonal transformation matrix Z = Z1 * Z2. +C Workspace: need N; prefer N*NB. +C + CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C +C Annihilate the lower part of A and B. +C + IF ( N.GT.2 ) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF ( N.GT.1 ) + $ CALL DLASET( 'F', N-1, 1, ZERO, ZERO, B(2), N-1 ) +C +C Find NCONT by checking sizes of the sub-diagonal elements of +C transformed A. +C + IF ( TOL.LE.ZERO ) TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) +C + J = 1 +C +C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO +C + 10 CONTINUE + IF ( J.LT.N ) THEN + IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN + J = J + 1 + GO TO 10 + END IF + END IF +C +C END WHILE 10 +C +C First negligible sub-diagonal element found, if any: set NCONT. +C + NCONT = J + IF ( J.LT.N ) A(J+1,J) = ZERO +C +C Undo scaling of A and B. +C + CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, + $ LDA, INFO ) + CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) + IF ( NCONT.LT.N ) + $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, + $ A(1,NCONT+1), LDA, INFO ) + ELSE +C +C B is negligible compared with A. No computations for reducing +C the system to orthogonal canonical form have been performed, +C except scaling (which is undoed). +C + IF( LJOBF ) THEN + CALL DLASET( 'F', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'F', N, 1, ZERO, ZERO, TAU, N ) + ELSE IF( LJOBI ) THEN + CALL DLASET( 'F', N, N, ZERO, ONE, Z, LDZ ) + END IF + CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, + $ INFO ) + CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB01MD *** + END diff --git a/mex/sources/libslicot/AB01ND.f b/mex/sources/libslicot/AB01ND.f new file mode 100644 index 000000000..c6280fcbe --- /dev/null +++ b/mex/sources/libslicot/AB01ND.f @@ -0,0 +1,470 @@ + SUBROUTINE AB01ND( JOBZ, N, M, A, LDA, B, LDB, NCONT, INDCON, + $ NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a controllable realization for the linear time-invariant +C multi-input system +C +C dX/dt = A * X + B * U, +C +C where A and B are N-by-N and N-by-M matrices, respectively, +C which are reduced by this routine to orthogonal canonical form +C using (and optionally accumulating) orthogonal similarity +C transformations. Specifically, the pair (A, B) is reduced to +C the pair (Ac, Bc), Ac = Z' * A * Z, Bc = Z' * B, given by +C +C [ Acont * ] [ Bcont ] +C Ac = [ ], Bc = [ ], +C [ 0 Auncont ] [ 0 ] +C +C and +C +C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] +C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] +C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] +C Acont = [ . . . . . . . ], Bc = [ . ], +C [ . . . . . . ] [ . ] +C [ . . . . . ] [ . ] +C [ 0 0 . . . Ap,p-1 App ] [ 0 ] +C +C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and +C p is the controllability index of the pair. The size of the +C block Auncont is equal to the dimension of the uncontrollable +C subspace of the pair (A, B). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal similarity transformations for +C reducing the system, as follows: +C = 'N': Do not form Z and do not store the orthogonal +C transformations; +C = 'F': Do not form Z, but store the orthogonal +C transformations in the factored form; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NCONT-by-NCONT part contains the +C upper block Hessenberg state dynamics matrix Acont in Ac, +C given by Z' * A * Z, of a controllable realization for +C the original system. The elements below the first block- +C subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading NCONT-by-M part of this array +C contains the transformed input matrix Bcont in Bc, given +C by Z' * B, with all elements but the first block set to +C zero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C NCONT (output) INTEGER +C The order of the controllable state-space representation. +C +C INDCON (output) INTEGER +C The controllability index of the controllable part of the +C system representation. +C +C NBLK (output) INTEGER array, dimension (N) +C The leading INDCON elements of this array contain the +C the orders of the diagonal blocks of Acont. +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C If JOBZ = 'I', then the leading N-by-N part of this +C array contains the matrix of accumulated orthogonal +C similarity transformations which reduces the given system +C to orthogonal canonical form. +C If JOBZ = 'F', the elements below the diagonal, with the +C array TAU, represent the orthogonal transformation matrix +C as a product of elementary reflectors. The transformation +C matrix can then be obtained by calling the LAPACK Library +C routine DORGQR. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'I' or +C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The elements of TAU contain the scalar factors of the +C elementary reflectors used in the reduction of B and A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N, 3*M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Matrix B is first QR-decomposed and the appropriate orthogonal +C similarity transformation applied to the matrix A. Leaving the +C first rank(B) states unchanged, the remaining lower left block +C of A is then QR-decomposed and the new orthogonal matrix, Q1, +C is also applied to the right of A to complete the similarity +C transformation. By continuing in this manner, a completely +C controllable state-space pair (Acont, Bcont) is found for the +C given (A, B), where Acont is upper block Hessenberg with each +C subdiagonal block of full row rank, and Bcont is zero apart from +C its (independent) first rank(B) rows. +C NOTE that the system controllability indices are easily +C calculated from the dimensions of the blocks of Acont. +C +C REFERENCES +C +C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. +C Orthogonal Invariants and Canonical Forms for Linear +C Controllable Systems. +C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. +C +C [2] Paige, C.C. +C Properties of numerical algorithms related to computing +C controllablity. +C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. +C +C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and +C Postlethwaite, I. +C Optimal Pole Assignment Design of Linear Multi-Input Systems. +C Leicester University, Report 99-11, May 1996. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C If the system matrices A and B are badly scaled, it would be +C useful to scale them with SLICOT routine TB01ID, before calling +C the routine. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB01BD by P.Hr. Petkov. +C +C REVISIONS +C +C January 14, 1997, June 4, 1997, February 13, 1998, +C September 22, 2003, February 29, 2004. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INDCON, INFO, LDA, LDB, LDWORK, LDZ, M, N, NCONT + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), Z(LDZ,*) + INTEGER IWORK(*), NBLK(*) +C .. Local Scalars .. + LOGICAL LJOBF, LJOBI, LJOBZ + INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, + $ WRKOPT + DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 + EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, + $ MB01PD, MB03OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + LJOBF = LSAME( JOBZ, 'F' ) + LJOBI = LSAME( JOBZ, 'I' ) + LJOBZ = LJOBF.OR.LJOBI +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.MAX( 1, N, 3*M ) ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB01ND', -INFO ) + RETURN + END IF +C + NCONT = 0 + INDCON = 0 +C +C Quick return if possible. +C + IF ( MIN( N, M ).EQ.0 ) THEN + IF( N.GT.0 ) THEN + IF ( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + ELSE IF ( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + END IF + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Calculate the absolute norms of A and B (used for scaling). +C + ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) + BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) +C +C Return if matrix B is zero. +C + IF( BNORM.EQ.ZERO ) THEN + IF ( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + ELSE IF ( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Scale (if needed) the matrices A and B. +C + CALL MB01PD( 'Scale', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, + $ INFO ) + CALL MB01PD( 'Scale', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, + $ INFO ) +C +C Compute the Frobenius norm of [ B A ] (used for rank estimation). +C + FNRM = DLAPY2( DLANGE( 'F', N, M, B, LDB, DWORK ), + $ DLANGE( 'F', N, N, A, LDA, DWORK ) ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) + END IF +C + WRKOPT = 1 + NI = 0 + ITAU = 1 + NCRT = N + MCRT = M + IQR = 1 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + 10 CONTINUE +C +C Rank-revealing QR decomposition with column pivoting. +C The calculation is performed in NCRT rows of B starting from +C the row IQR (initialized to 1 and then set to rank(B)+1). +C Workspace: 3*MCRT. +C + CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, + $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) +C + IF ( RANK.NE.0 ) THEN + NJ = NI + NI = NCONT + NCONT = NCONT + RANK + INDCON = INDCON + 1 + NBLK(INDCON) = RANK +C +C Premultiply and postmultiply the appropriate block row +C and block column of A by Q' and Q, respectively. +C Workspace: need NCRT; +C prefer NCRT*NB. +C + CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Workspace: need N; +C prefer N*NB. +C + CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C If required, save transformations. +C + IF ( LJOBZ.AND.NCRT.GT.1 ) THEN + CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), + $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) + END IF +C +C Zero the subdiagonal elements of the current matrix. +C + IF ( RANK.GT.1 ) + $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), + $ LDB ) +C +C Backward permutation of the columns of B or A. +C + IF ( INDCON.EQ.1 ) THEN + CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) + IQR = RANK + 1 + ELSE + DO 20 J = 1, MCRT + CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), + $ 1 ) + 20 CONTINUE + END IF +C + ITAU = ITAU + RANK + IF ( RANK.NE.NCRT ) THEN + MCRT = RANK + NCRT = NCRT - RANK + CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, + $ B(IQR,1), LDB ) + CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, + $ A(NCONT+1,NI+1), LDA ) + GO TO 10 + END IF + END IF +C +C If required, accumulate transformations. +C Workspace: need N; prefer N*NB. +C + IF ( LJOBI ) THEN + CALL DORGQR( N, N, MAX( 1, ITAU-1 ), Z, LDZ, TAU, DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C +C Annihilate the trailing blocks of B. +C + IF ( N.GE.IQR ) + $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) +C +C Annihilate the trailing elements of TAU, if JOBZ = 'F'. +C + IF ( LJOBF ) THEN + DO 30 J = ITAU, N + TAU(J) = ZERO + 30 CONTINUE + END IF +C +C Undo scaling of A and B. +C + IF ( INDCON.LT.N ) THEN + NBL = INDCON + 1 + NBLK(NBL) = N - NCONT + ELSE + NBL = 0 + END IF + CALL MB01PD( 'Undo', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, + $ LDA, INFO ) + CALL MB01PD( 'Undo', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, + $ LDB, INFO ) +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB01ND *** + END diff --git a/mex/sources/libslicot/AB01OD.f b/mex/sources/libslicot/AB01OD.f new file mode 100644 index 000000000..f85ed5626 --- /dev/null +++ b/mex/sources/libslicot/AB01OD.f @@ -0,0 +1,535 @@ + SUBROUTINE AB01OD( STAGES, JOBU, JOBV, N, M, A, LDA, B, LDB, U, + $ LDU, V, LDV, NCONT, INDCON, KSTAIR, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the matrices A and B using (and optionally accumulating) +C state-space and input-space transformations U and V respectively, +C such that the pair of matrices +C +C Ac = U' * A * U, Bc = U' * B * V +C +C are in upper "staircase" form. Specifically, +C +C [ Acont * ] [ Bcont ] +C Ac = [ ], Bc = [ ], +C [ 0 Auncont ] [ 0 ] +C +C and +C +C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] +C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] +C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] +C Acont = [ . . . . . . . ], Bc = [ . ], +C [ . . . . . . ] [ . ] +C [ . . . . . ] [ . ] +C [ 0 0 . . . Ap,p-1 App ] [ 0 ] +C +C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and +C p is the controllability index of the pair. The size of the +C block Auncont is equal to the dimension of the uncontrollable +C subspace of the pair (A, B). The first stage of the reduction, +C the "forward" stage, accomplishes the reduction to the orthogonal +C canonical form (see SLICOT library routine AB01ND). The blocks +C B1, A21, ..., Ap,p-1 are further reduced in a second, "backward" +C stage to upper triangular form using RQ factorization. Each of +C these stages is optional. +C +C ARGUMENTS +C +C Mode Parameters +C +C STAGES CHARACTER*1 +C Specifies the reduction stages to be performed as follows: +C = 'F': Perform the forward stage only; +C = 'B': Perform the backward stage only; +C = 'A': Perform both (all) stages. +C +C JOBU CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix U the state-space transformations as follows: +C = 'N': Do not form U; +C = 'I': U is internally initialized to the unit matrix (if +C STAGES <> 'B'), or updated (if STAGES = 'B'), and +C the orthogonal transformation matrix U is +C returned. +C +C JOBV CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix V the input-space transformations as follows: +C = 'N': Do not form V; +C = 'I': V is initialized to the unit matrix and the +C orthogonal transformation matrix V is returned. +C JOBV is not referenced if STAGES = 'F'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The actual input dimension. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state transition matrix A to be transformed. +C If STAGES = 'B', A should be in the orthogonal canonical +C form, as returned by SLICOT library routine AB01ND. +C On exit, the leading N-by-N part of this array contains +C the transformed state transition matrix U' * A * U. +C The leading NCONT-by-NCONT part contains the upper block +C Hessenberg state matrix Acont in Ac, given by U' * A * U, +C of a controllable realization for the original system. +C The elements below the first block-subdiagonal are set to +C zero. If STAGES <> 'F', the subdiagonal blocks of A are +C triangularized by RQ factorization, and the annihilated +C elements are explicitly zeroed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B to be transformed. +C If STAGES = 'B', B should be in the orthogonal canonical +C form, as returned by SLICOT library routine AB01ND. +C On exit with STAGES = 'F', the leading N-by-M part of +C this array contains the transformed input matrix U' * B, +C with all elements but the first block set to zero. +C On exit with STAGES <> 'F', the leading N-by-M part of +C this array contains the transformed input matrix +C U' * B * V, with all elements but the first block set to +C zero and the first block in upper triangular form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C If STAGES <> 'B' or JOBU = 'N', then U need not be set +C on entry. +C If STAGES = 'B' and JOBU = 'I', then, on entry, the +C leading N-by-N part of this array must contain the +C transformation matrix U that reduced the pair to the +C orthogonal canonical form. +C On exit, if JOBU = 'I', the leading N-by-N part of this +C array contains the transformation matrix U that performed +C the specified reduction. +C If JOBU = 'N', the array U is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDU = 1 and +C declare this array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. +C If JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. +C +C V (output) DOUBLE PRECISION array, dimension (LDV,M) +C If JOBV = 'I', then the leading M-by-M part of this array +C contains the transformation matrix V. +C If STAGES = 'F', or JOBV = 'N', the array V is not +C referenced and can be supplied as a dummy array (i.e. set +C parameter LDV = 1 and declare this array to be V(1,1) in +C the calling program). +C +C LDV INTEGER +C The leading dimension of array V. +C If STAGES <> 'F' and JOBV = 'I', LDV >= MAX(1,M); +C if STAGES = 'F' or JOBV = 'N', LDV >= 1. +C +C NCONT (input/output) INTEGER +C The order of the controllable state-space representation. +C NCONT is input only if STAGES = 'B'. +C +C INDCON (input/output) INTEGER +C The number of stairs in the staircase form (also, the +C controllability index of the controllable part of the +C system representation). +C INDCON is input only if STAGES = 'B'. +C +C KSTAIR (input/output) INTEGER array, dimension (N) +C The leading INDCON elements of this array contain the +C dimensions of the stairs, or, also, the orders of the +C diagonal blocks of Acont. +C KSTAIR is input if STAGES = 'B', and output otherwise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). +C TOL is not referenced if STAGES = 'B'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C IWORK is not referenced if STAGES = 'B'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If STAGES <> 'B', LDWORK >= MAX(1, N + MAX(N,3*M)); +C If STAGES = 'B', LDWORK >= MAX(1, M + MAX(N,M)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Staircase reduction of the pencil [B|sI - A] is used. Orthogonal +C transformations U and V are constructed such that +C +C +C |B |sI-A * . . . * * | +C | 1| 11 . . . | +C | | A sI-A . . . | +C | | 21 22 . . . | +C | | . . * * | +C [U'BV|sI - U'AU] = |0 | 0 . . | +C | | A sI-A * | +C | | p,p-1 pp | +C | | | +C |0 | 0 0 sI-A | +C | | p+1,p+1| +C +C +C where the i-th diagonal block of U'AU has dimension KSTAIR(i), +C for i = 1,...,p. The value of p is returned in INDCON. The last +C block contains the uncontrollable modes of the (A,B)-pair which +C are also the generalized eigenvalues of the above pencil. +C +C The complete reduction is performed in two stages. The first, +C forward stage accomplishes the reduction to the orthogonal +C canonical form. The second, backward stage consists in further +C reduction to triangular form by applying left and right orthogonal +C transformations. +C +C REFERENCES +C +C [1] Van Dooren, P. +C The generalized eigenvalue problem in linear system theory. +C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. +C +C [2] Miminis, G. and Paige, C. +C An algorithm for pole assignment of time-invariant multi-input +C linear systems. +C Proc. 21st IEEE CDC, Orlando, Florida, 1, pp. 62-67, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O((N + M) x N**2) operations and is +C backward stable (see [1]). +C +C FURTHER COMMENTS +C +C If the system matrices A and B are badly scaled, it would be +C useful to scale them with SLICOT routine TB01ID, before calling +C the routine. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB01CD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C January 14, 1997, February 12, 1998, September 22, 2003. +C +C KEYWORDS +C +C Controllability, generalized eigenvalue problem, orthogonal +C transformation, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBU, JOBV, STAGES + INTEGER INDCON, INFO, LDA, LDB, LDU, LDV, LDWORK, M, N, + $ NCONT + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*), KSTAIR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + LOGICAL LJOBUI, LJOBVI, LSTAGB, LSTGAB + INTEGER I, I0, IBSTEP, ITAU, J0, JINI, JWORK, MCRT, MM, + $ NCRT, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB01ND, DGERQF, DLACPY, DLASET, DORGRQ, DORMRQ, + $ DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LJOBUI = LSAME( JOBU, 'I' ) +C + LSTAGB = LSAME( STAGES, 'B' ) + LSTGAB = LSAME( STAGES, 'A' ).OR.LSTAGB +C + IF ( LSTGAB ) THEN + LJOBVI = LSAME( JOBV, 'I' ) + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.LSTGAB .AND. .NOT.LSAME( STAGES, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBUI .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDU.LT.1 .OR. ( LJOBUI .AND. LDU.LT.N ) ) THEN + INFO = -11 + ELSE IF( .NOT.LSTAGB .AND. LDWORK.LT.MAX( 1, N + MAX( N, 3*M ) ) + $ .OR. LSTAGB .AND. LDWORK.LT.MAX( 1, M + MAX( N, M ) ) ) + $ THEN + INFO = -20 + ELSE IF( LSTAGB .AND. NCONT.GT.N ) THEN + INFO = -14 + ELSE IF( LSTAGB .AND. INDCON.GT.N ) THEN + INFO = -15 + ELSE IF( LSTGAB ) THEN + IF( .NOT.LJOBVI .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -3 + ELSE IF( LDV.LT.1 .OR. ( LJOBVI .AND. LDV.LT.M ) ) THEN + INFO = -13 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( N, M ).EQ.0 ) THEN + NCONT = 0 + INDCON = 0 + IF( N.GT.0 .AND. LJOBUI ) + $ CALL DLASET( 'F', N, N, ZERO, ONE, U, LDU ) + IF( LSTGAB ) THEN + IF( M.GT.0 .AND. LJOBVI ) + $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) + END IF + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + ITAU = 1 + WRKOPT = 1 +C + IF ( .NOT.LSTAGB ) THEN +C +C Perform the forward stage computations of the staircase +C algorithm on B and A: reduce the (A, B) pair to orthogonal +C canonical form. +C +C Workspace: N + MAX(N,3*M). +C + JWORK = N + 1 + CALL AB01ND( JOBU, N, M, A, LDA, B, LDB, NCONT, INDCON, + $ KSTAIR, U, LDU, DWORK(ITAU), TOL, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 + END IF +C +C Exit if no further reduction to triangularize B1 and subdiagonal +C blocks of A is required, or if the order of the controllable part +C is 0. +C + IF ( .NOT.LSTGAB ) THEN + DWORK(1) = WRKOPT + RETURN + ELSE IF ( NCONT.EQ.0 .OR. INDCON.EQ.0 ) THEN + IF( LJOBVI ) + $ CALL DLASET( 'F', M, M, ZERO, ONE, V, LDV ) + DWORK(1) = WRKOPT + RETURN + END IF +C +C Now perform the backward steps except the last one. +C + MCRT = KSTAIR(INDCON) + I0 = NCONT - MCRT + 1 + JWORK = M + 1 +C + DO 10 IBSTEP = INDCON, 2, -1 + NCRT = KSTAIR(IBSTEP-1) + J0 = I0 - NCRT + MM = MIN( NCRT, MCRT ) +C +C Compute the RQ factorization of the current subdiagonal block +C of A, Ai,i-1 = R*Q (where i is IBSTEP), of dimension +C MCRT-by-NCRT, starting in position (I0,J0). +C The matrix Q' should postmultiply U, if required. +C Workspace: need M + MCRT; +C prefer M + MCRT*NB. +C + CALL DGERQF( MCRT, NCRT, A(I0,J0), LDA, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Set JINI to the first column number in A where the current +C transformation Q is to be applied, taking the block Hessenberg +C form into account. +C + IF ( IBSTEP.GT.2 ) THEN + JINI = J0 - KSTAIR(IBSTEP-2) + ELSE + JINI = 1 +C +C Premultiply the first block row (B1) of B by Q. +C Workspace: need 2*M; +C prefer M + M*NB. +C + CALL DORMRQ( 'Left', 'No transpose', NCRT, M, MM, A(I0,J0), + $ LDA, DWORK(ITAU), B, LDB, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Premultiply the appropriate block row of A by Q. +C Workspace: need M + N; +C prefer M + N*NB. +C + CALL DORMRQ( 'Left', 'No transpose', NCRT, N-JINI+1, MM, + $ A(I0,J0), LDA, DWORK(ITAU), A(J0,JINI), LDA, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Postmultiply the appropriate block column of A by Q'. +C Workspace: need M + I0-1; +C prefer M + (I0-1)*NB. +C + CALL DORMRQ( 'Right', 'Transpose', I0-1, NCRT, MM, A(I0,J0), + $ LDA, DWORK(ITAU), A(1,J0), LDA, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LJOBUI ) THEN +C +C Update U, postmultiplying it by Q'. +C Workspace: need M + N; +C prefer M + N*NB. +C + CALL DORMRQ( 'Right', 'Transpose', N, NCRT, MM, A(I0,J0), + $ LDA, DWORK(ITAU), U(1,J0), LDU, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Zero the subdiagonal elements of the current subdiagonal block +C of A. +C + CALL DLASET( 'F', MCRT, NCRT-MCRT, ZERO, ZERO, A(I0,J0), LDA ) + IF ( I0.LT.N ) + $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, + $ A(I0+1,I0-MCRT), LDA ) +C + MCRT = NCRT + I0 = J0 +C + 10 CONTINUE +C +C Now perform the last backward step on B, V = Qb'. +C +C Compute the RQ factorization of the first block of B, B1 = R*Qb. +C Workspace: need M + MCRT; +C prefer M + MCRT*NB. +C + CALL DGERQF( MCRT, M, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LJOBVI ) THEN +C +C Accumulate the input-space transformations V. +C Workspace: need 2*M; prefer M + M*NB. +C + CALL DLACPY( 'F', MCRT, M-MCRT, B, LDB, V(M-MCRT+1,1), LDV ) + IF ( MCRT.GT.1 ) + $ CALL DLACPY( 'L', MCRT-1, MCRT-1, B(2,M-MCRT+1), LDB, + $ V(M-MCRT+2,M-MCRT+1), LDV ) + CALL DORGRQ( M, M, MCRT, V, LDV, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C + DO 20 I = 2, M + CALL DSWAP( I-1, V(I,1), LDV, V(1,I), 1 ) + 20 CONTINUE +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + END IF +C +C Zero the subdiagonal elements of the submatrix B1. +C + CALL DLASET( 'F', MCRT, M-MCRT, ZERO, ZERO, B, LDB ) + IF ( MCRT.GT.1 ) + $ CALL DLASET( 'L', MCRT-1, MCRT-1, ZERO, ZERO, B(2,M-MCRT+1), + $ LDB ) +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB01OD *** + END diff --git a/mex/sources/libslicot/AB04MD.f b/mex/sources/libslicot/AB04MD.f new file mode 100644 index 000000000..b5856fcd9 --- /dev/null +++ b/mex/sources/libslicot/AB04MD.f @@ -0,0 +1,345 @@ + SUBROUTINE AB04MD( TYPE, N, M, P, ALPHA, BETA, A, LDA, B, LDB, C, + $ LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform a transformation on the parameters (A,B,C,D) of a +C system, which is equivalent to a bilinear transformation of the +C corresponding transfer function matrix. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPE CHARACTER*1 +C Indicates the type of the original system and the +C transformation to be performed as follows: +C = 'D': discrete-time -> continuous-time; +C = 'C': continuous-time -> discrete-time. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C ALPHA, (input) DOUBLE PRECISION +C BETA Parameters specifying the bilinear transformation. +C Recommended values for stable systems: ALPHA = 1, +C BETA = 1. ALPHA <> 0, BETA <> 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state matrix A of the original system. +C On exit, the leading N-by-N part of this array contains +C _ +C the state matrix A of the transformed system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the original system. +C On exit, the leading N-by-M part of this array contains +C _ +C the input matrix B of the transformed system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C of the original system. +C On exit, the leading P-by-N part of this array contains +C _ +C the output matrix C of the transformed system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix D for the original system. +C On exit, the leading P-by-M part of this array contains +C _ +C the input/output matrix D of the transformed system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C For optimum performance LDWORK >= MAX(1,N*NB), where NB +C is the optimal blocksize. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix (ALPHA*I + A) is exactly singular; +C = 2: if the matrix (BETA*I - A) is exactly singular. +C +C METHOD +C +C The parameters of the discrete-time system are transformed into +C the parameters of the continuous-time system (TYPE = 'D'), or +C vice-versa (TYPE = 'C') by the transformation: +C +C 1. Discrete -> continuous +C _ -1 +C A = beta*(alpha*I + A) * (A - alpha*I) +C _ -1 +C B = sqrt(2*alpha*beta) * (alpha*I + A) * B +C _ -1 +C C = sqrt(2*alpha*beta) * C * (alpha*I + A) +C _ -1 +C D = D - C * (alpha*I + A) * B +C +C which is equivalent to the bilinear transformation +C +C z - alpha +C z -> s = beta --------- . +C z + alpha +C +C of one transfer matrix onto the other. +C +C 2. Continuous -> discrete +C _ -1 +C A = alpha*(beta*I - A) * (beta*I + A) +C _ -1 +C B = sqrt(2*alpha*beta) * (beta*I - A) * B +C _ -1 +C C = sqrt(2*alpha*beta) * C * (beta*I - A) +C _ -1 +C D = D + C * (beta*I - A) * B +C +C which is equivalent to the bilinear transformation +C +C beta + s +C s -> z = alpha -------- . +C beta - s +C +C of one transfer matrix onto the other. +C +C REFERENCES +C +C [1] Al-Saggaf, U.M. and Franklin, G.F. +C Model reduction via balanced realizations: a extension and +C frequency weighting techniques. +C IEEE Trans. Autom. Contr., AC-33, pp. 687-692, 1988. +C +C NUMERICAL ASPECTS +C 3 +C The time taken is approximately proportional to N . +C The accuracy depends mainly on the condition number of the matrix +C to be inverted. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, Nov. 1996. +C Supersedes Release 2.0 routine AB04AD by W. van der Linden, and +C A.J. Geurts, Technische Hogeschool Eindhoven, Holland. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Bilinear transformation, continuous-time system, discrete-time +C system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LTYPE + INTEGER I, IP + DOUBLE PRECISION AB2, PALPHA, PBETA, SQRAB2 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DGETRF, DGETRS, DGETRI, DLASCL, DSCAL, + $ DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Executable Statements .. +C + INFO = 0 + LTYPE = LSAME( TYPE, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LTYPE .AND. .NOT.LSAME( TYPE, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( ALPHA.EQ.ZERO ) THEN + INFO = -5 + ELSE IF( BETA.EQ.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB04MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) + $ RETURN +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF (LTYPE) THEN +C +C Discrete-time to continuous-time with (ALPHA, BETA). +C + PALPHA = ALPHA + PBETA = BETA + ELSE +C +C Continuous-time to discrete-time with (ALPHA, BETA) is +C equivalent with discrete-time to continuous-time with +C (-BETA, -ALPHA), if B and C change the sign. +C + PALPHA = -BETA + PBETA = -ALPHA + END IF +C + AB2 = PALPHA*PBETA*TWO + SQRAB2 = SIGN( SQRT( ABS( AB2 ) ), PALPHA ) +C -1 +C Compute (alpha*I + A) . +C + DO 10 I = 1, N + A(I,I) = A(I,I) + PALPHA + 10 CONTINUE +C + CALL DGETRF( N, N, A, LDA, IWORK, INFO ) +C + IF (INFO.NE.0) THEN +C +C Error return. +C + IF (LTYPE) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C -1 +C Compute (alpha*I+A) *B. +C + CALL DGETRS( 'No transpose', N, M, A, LDA, IWORK, B, LDB, INFO ) +C -1 +C Compute D - C*(alpha*I+A) *B. +C + CALL DGEMM( 'No transpose', 'No transpose', P, M, N, -ONE, C, + $ LDC, B, LDB, ONE, D, LDD ) +C +C Scale B by sqrt(2*alpha*beta). +C + CALL DLASCL( 'General', 0, 0, ONE, SQRAB2, N, M, B, LDB, INFO ) +C -1 +C Compute sqrt(2*alpha*beta)*C*(alpha*I + A) . +C + CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', P, N, + $ SQRAB2, A, LDA, C, LDC ) +C + CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', P, N, ONE, + $ A, LDA, C, LDC ) +C +C Apply column interchanges to the solution matrix. +C + DO 20 I = N-1, 1, -1 + IP = IWORK(I) + IF ( IP.NE.I ) + $ CALL DSWAP( P, C(1,I), 1, C(1,IP), 1 ) + 20 CONTINUE +C -1 +C Compute beta*(alpha*I + A) *(A - alpha*I) as +C -1 +C beta*I - 2*alpha*beta*(alpha*I + A) . +C +C Workspace: need N; prefer N*NB. +C + CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) +C + DO 30 I = 1, N + CALL DSCAL(N, -AB2, A(1,I), 1) + A(I,I) = A(I,I) + PBETA + 30 CONTINUE +C + RETURN +C *** Last line of AB04MD *** + END diff --git a/mex/sources/libslicot/AB05MD.f b/mex/sources/libslicot/AB05MD.f new file mode 100644 index 000000000..0324368bf --- /dev/null +++ b/mex/sources/libslicot/AB05MD.f @@ -0,0 +1,547 @@ + SUBROUTINE AB05MD( UPLO, OVER, N1, M1, P1, N2, P2, A1, LDA1, B1, + $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, + $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, + $ D, LDD, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To obtain the state-space model (A,B,C,D) for the cascaded +C inter-connection of two systems, each given in state-space form. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates whether the user wishes to obtain the matrix A +C in the upper or lower block diagonal form, as follows: +C = 'U': Obtain A in the upper block diagonal form; +C = 'L': Obtain A in the lower block diagonal form. +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D (for UPLO = 'L'), or A2 +C and A, B2 and B, C2 and C, and D2 and D (for +C UPLO = 'U'), i.e. the same name is effectively +C used for each pair (for all pairs) in the routine +C call. In this case, setting LDA1 = LDA, +C LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD, or +C LDA2 = LDA, LDB2 = LDB, LDC2 = LDC, and LDD2 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1. N1 >= 0. +C +C M1 (input) INTEGER +C The number of input variables for the first system. +C M1 >= 0. +C +C P1 (input) INTEGER +C The number of output variables from the first system and +C the number of input variables for the second system. +C P1 >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2. N2 >= 0. +C +C P2 (input) INTEGER +C The number of output variables from the second system. +C P2 >= 0. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) +C The leading N1-by-M1 part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P1-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P1) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) +C The leading P1-by-M1 part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P1). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) +C The leading N2-by-P1 part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading P2-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,P2) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) +C The leading P2-by-P1 part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,P2). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the resulting +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the cascaded system. +C If OVER = 'O', the array A can overlap A1, if UPLO = 'L', +C or A2, if UPLO = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M1) +C The leading N-by-M1 part of this array contains the +C input/state matrix B for the cascaded system. +C If OVER = 'O', the array B can overlap B1, if UPLO = 'L', +C or B2, if UPLO = 'U'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P2-by-N part of this array contains the +C state/output matrix C for the cascaded system. +C If OVER = 'O', the array C can overlap C1, if UPLO = 'L', +C or C2, if UPLO = 'U'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P2) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M1) +C The leading P2-by-M1 part of this array contains the +C input/output matrix D for the cascaded system. +C If OVER = 'O', the array D can overlap D1, if UPLO = 'L', +C or D2, if UPLO = 'U'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P2). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The array DWORK is not referenced if OVER = 'N'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, P1*MAX(N1, M1, N2, P2) ) if OVER = 'O'. +C LDWORK >= 1 if OVER = 'N'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C After cascaded inter-connection of the two systems +C +C X1' = A1*X1 + B1*U +C V = C1*X1 + D1*U +C +C X2' = A2*X2 + B2*V +C Y = C2*X2 + D2*V +C +C (where ' denotes differentiation with respect to time) +C +C the following state-space model will be obtained: +C +C X' = A*X + B*U +C Y = C*X + D*U +C +C where matrix A has the form ( A1 0 ), +C ( B2*C1 A2) +C +C matrix B has the form ( B1 ), +C ( B2*D1 ) +C +C matrix C has the form ( D2*C1 C2 ) and +C +C matrix D has the form ( D2*D1 ). +C +C This form is returned by the routine when UPLO = 'L'. Note that +C when A1 and A2 are block lower triangular, the resulting state +C matrix is also block lower triangular. +C +C By applying a similarity transformation to the system above, +C using the matrix ( 0 I ), where I is the identity matrix of +C ( J 0 ) +C order N2, and J is the identity matrix of order N1, the +C system matrices become +C +C A = ( A2 B2*C1 ), +C ( 0 A1 ) +C +C B = ( B2*D1 ), +C ( B1 ) +C +C C = ( C2 D2*C1 ) and +C +C D = ( D2*D1 ). +C +C This form is returned by the routine when UPLO = 'U'. Note that +C when A1 and A2 are block upper triangular (for instance, in the +C real Schur form), the resulting state matrix is also block upper +C triangular. +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C The algorithm requires P1*(N1+M1)*(N2+P2) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, and +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, Nov. 1996. +C Supersedes Release 2.0 routine AB05AD by C.J.Benson, Kingston +C Polytechnic, United Kingdom, January 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Feb. 2004. +C +C KEYWORDS +C +C Cascade control, continuous-time system, multivariable +C system, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER, UPLO + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, + $ N2, P1, P2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), + $ DWORK(*) +C .. Local Scalars .. + LOGICAL LOVER, LUPLO + INTEGER I, I1, I2, J, LDWN2, LDWP1, LDWP2 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + LUPLO = LSAME( UPLO, 'L' ) + N = N1 + N2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -2 + ELSE IF( N1.LT.0 ) THEN + INFO = -3 + ELSE IF( M1.LT.0 ) THEN + INFO = -4 + ELSE IF( P1.LT.0 ) THEN + INFO = -5 + ELSE IF( N2.LT.0 ) THEN + INFO = -6 + ELSE IF( P2.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -9 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -11 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -13 + ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN + INFO = -15 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -17 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -19 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -21 + ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN + INFO = -23 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -28 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P2 ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -30 + ELSE IF( LDD.LT.MAX( 1, P2 ) ) THEN + INFO = -32 + ELSE IF( ( LOVER.AND.LDWORK.LT.MAX( 1, P1*MAX( N1, M1, N2, P2 )) ) + $.OR.( .NOT.LOVER.AND.LDWORK.LT.1 ) ) THEN + INFO = -34 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M1, P2 ) ).EQ.0 ) + $ RETURN +C +C Set row/column indices for storing the results. +C + IF ( LUPLO ) THEN + I1 = 1 + I2 = MIN( N1 + 1, N ) + ELSE + I1 = MIN( N2 + 1, N ) + I2 = 1 + END IF +C + LDWN2 = MAX( 1, N2 ) + LDWP1 = MAX( 1, P1 ) + LDWP2 = MAX( 1, P2 ) +C +C Construct the cascaded system matrices, taking the desired block +C structure and possible overwriting into account. +C +C Form the diagonal blocks of matrix A. +C + IF ( LUPLO ) THEN +C +C Lower block diagonal structure. +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 20 J = N1, 1, -1 + DO 10 I = N1, 1, -1 + A(I,J) = A1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF + IF ( N2.GT.0 ) + $ CALL DLACPY( 'F', N2, N2, A2, LDA2, A(I2,I2), LDA ) + ELSE +C +C Upper block diagonal structure. +C + IF ( LOVER .AND. LDA2.LE.LDA ) THEN + IF ( LDA2.LT.LDA ) THEN +C + DO 40 J = N2, 1, -1 + DO 30 I = N2, 1, -1 + A(I,J) = A2(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N2, N2, A2, LDA2, A, LDA ) + END IF + IF ( N1.GT.0 ) + $ CALL DLACPY( 'F', N1, N1, A1, LDA1, A(I1,I1), LDA ) + END IF +C +C Form the off-diagonal blocks of matrix A. +C + IF ( MIN( N1, N2 ).GT.0 ) THEN + CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(I1,I2), LDA ) + CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, ONE, + $ B2, LDB2, C1, LDC1, ZERO, A(I2,I1), LDA ) + END IF +C + IF ( LUPLO ) THEN +C +C Form the matrix B. +C + IF ( LOVER .AND. LDB1.LE.LDB ) THEN + IF ( LDB1.LT.LDB ) THEN +C + DO 60 J = M1, 1, -1 + DO 50 I = N1, 1, -1 + B(I,J) = B1(I,J) + 50 CONTINUE + 60 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) + END IF +C + IF ( MIN( N2, M1 ).GT.0 ) + $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, + $ ONE, B2, LDB2, D1, LDD1, ZERO, B(I2,1), LDB ) +C +C Form the matrix C. +C + IF ( N1.GT.0 ) THEN + IF ( LOVER ) THEN +C +C Workspace: P1*N1. +C + CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK, LDWP1 ) + CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, + $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, C, LDC ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, + $ ONE, D2, LDD2, C1, LDC1, ZERO, C, LDC ) + END IF + END IF +C + IF ( MIN( P2, N2 ).GT.0 ) + $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(1,I2), LDC ) +C +C Now form the matrix D. +C + IF ( LOVER ) THEN +C +C Workspace: P1*M1. +C + CALL DLACPY( 'F', P1, M1, D1, LDD1, DWORK, LDWP1 ) + CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, + $ ONE, D2, LDD2, DWORK, LDWP1, ZERO, D, LDD ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, + $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) + END IF +C + ELSE +C +C Form the matrix B. +C + IF ( LOVER ) THEN +C +C Workspace: N2*P1. +C + CALL DLACPY( 'F', N2, P1, B2, LDB2, DWORK, LDWN2 ) + IF ( MIN( N2, M1 ).GT.0 ) + $ CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, + $ ONE, DWORK, LDWN2, D1, LDD1, ZERO, B(I2,1), + $ LDB ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, + $ ONE, B2, LDB2, D1, LDD1, ZERO, B, LDB ) + END IF +C + IF ( MIN( N1, M1 ).GT.0 ) + $ CALL DLACPY( 'F', N1, M1, B1, LDB1, B(I1,1), LDB ) +C +C Form the matrix C. +C + IF ( LOVER .AND. LDC2.LE.LDC ) THEN + IF ( LDC2.LT.LDC ) THEN +C + DO 80 J = N2, 1, -1 + DO 70 I = P2, 1, -1 + C(I,J) = C2(I,J) + 70 CONTINUE + 80 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P2, N2, C2, LDC2, C, LDC ) + END IF +C + IF ( MIN( P2, N1 ).GT.0 ) + $ CALL DGEMM ( 'No transpose', 'No transpose', P2, N1, P1, + $ ONE, D2, LDD2, C1, LDC1, ZERO, C(1,I1), LDC ) +C +C Now form the matrix D. +C + IF ( LOVER ) THEN +C +C Workspace: P2*P1. +C + CALL DLACPY( 'F', P2, P1, D2, LDD2, DWORK, LDWP2 ) + CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, + $ ONE, DWORK, LDWP2, D1, LDD1, ZERO, D, LDD ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', P2, M1, P1, + $ ONE, D2, LDD2, D1, LDD1, ZERO, D, LDD ) + END IF + END IF +C + RETURN +C *** Last line of AB05MD *** + END diff --git a/mex/sources/libslicot/AB05ND.f b/mex/sources/libslicot/AB05ND.f new file mode 100644 index 000000000..507d6ea16 --- /dev/null +++ b/mex/sources/libslicot/AB05ND.f @@ -0,0 +1,564 @@ + SUBROUTINE AB05ND( OVER, N1, M1, P1, N2, ALPHA, A1, LDA1, B1, + $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, + $ C2, LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, + $ D, LDD, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To obtain the state-space model (A,B,C,D) for the feedback +C inter-connection of two systems, each given in state-space form. +C +C ARGUMENTS +C +C Mode Parameters +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D, i.e. the same name is +C effectively used for each pair (for all pairs) +C in the routine call. In this case, setting +C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1. N1 >= 0. +C +C M1 (input) INTEGER +C The number of input variables for the first system and the +C number of output variables from the second system. +C M1 >= 0. +C +C P1 (input) INTEGER +C The number of output variables from the first system and +C the number of input variables for the second system. +C P1 >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2. N2 >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C A coefficient multiplying the transfer-function matrix +C (or the output equation) of the second system. +C ALPHA = +1 corresponds to positive feedback, and +C ALPHA = -1 corresponds to negative feedback. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) +C The leading N1-by-M1 part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P1-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P1) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) +C The leading P1-by-M1 part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P1). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,P1) +C The leading N2-by-P1 part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading M1-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,M1) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,P1) +C The leading M1-by-P1 part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,M1). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the connected +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the connected system. +C The array A can overlap A1 if OVER = 'O'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M1) +C The leading N-by-M1 part of this array contains the +C input/state matrix B for the connected system. +C The array B can overlap B1 if OVER = 'O'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P1-by-N part of this array contains the +C state/output matrix C for the connected system. +C The array C can overlap C1 if OVER = 'O'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P1) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M1) +C The leading P1-by-M1 part of this array contains the +C input/output matrix D for the connected system. +C The array D can overlap D1 if OVER = 'O'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P1). +C +C Workspace +C +C IWORK INTEGER array, dimension (P1) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. If OVER = 'N', +C LDWORK >= MAX(1, P1*P1, M1*M1, N1*P1), and if OVER = 'O', +C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*M1, N1*P1) ), +C if M1 <= N*N2; +C LDWORK >= MAX(1, N1*P1 + MAX( P1*P1, M1*(M1+1), N1*P1) ), +C if M1 > N*N2. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C > 0: if INFO = i, 1 <= i <= P1, the system is not +C completely controllable. That is, the matrix +C (I + ALPHA*D1*D2) is exactly singular (the element +C U(i,i) of the upper triangular factor of LU +C factorization is exactly zero), possibly due to +C rounding errors. +C +C METHOD +C +C After feedback inter-connection of the two systems, +C +C X1' = A1*X1 + B1*U1 +C Y1 = C1*X1 + D1*U1 +C +C X2' = A2*X2 + B2*U2 +C Y2 = C2*X2 + D2*U2 +C +C (where ' denotes differentiation with respect to time) +C +C the following state-space model will be obtained: +C +C X' = A*X + B*U +C Y = C*X + D*U +C +C where U = U1 + alpha*Y2, X = ( X1 ), +C Y = Y1 = U2, ( X2 ) +C +C matrix A has the form +C +C ( A1 - alpha*B1*E12*D2*C1 - alpha*B1*E12*C2 ), +C ( B2*E21*C1 A2 - alpha*B2*E21*D1*C2 ) +C +C matrix B has the form +C +C ( B1*E12 ), +C ( B2*E21*D1 ) +C +C matrix C has the form +C +C ( E21*C1 - alpha*E21*D1*C2 ), +C +C matrix D has the form +C +C ( E21*D1 ), +C +C E21 = ( I + alpha*D1*D2 )-INVERSE and +C E12 = ( I + alpha*D2*D1 )-INVERSE = I - alpha*D2*E21*D1. +C +C Taking N1 = 0 and/or N2 = 0 on the routine call will solve the +C constant plant and/or constant feedback cases. +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB05BD by C.J.Benson, Kingston +C Polytechnic, United Kingdom, January 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Feb. 2004. +C +C KEYWORDS +C +C Continuous-time system, multivariable system, state-space model, +C state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO=0.0D0, ONE=1.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, LDWORK, M1, N, N1, + $ N2, P1 + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*), + $ DWORK(*) +C .. Local Scalars .. + LOGICAL LOVER + INTEGER I, J, LDW, LDWM1 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, + $ DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + LDWM1 = MAX( 1, M1 ) + N = N1 + N2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -1 + ELSE IF( N1.LT.0 ) THEN + INFO = -2 + ELSE IF( M1.LT.0 ) THEN + INFO = -3 + ELSE IF( P1.LT.0 ) THEN + INFO = -4 + ELSE IF( N2.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -8 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -10 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -12 + ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN + INFO = -14 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -16 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -18 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.LDWM1 ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -20 + ELSE IF( LDD2.LT.LDWM1 ) THEN + INFO = -22 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -25 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -27 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -29 + ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN + INFO = -31 + ELSE + LDW = MAX( P1*P1, M1*M1, N1*P1 ) + IF( LOVER ) THEN + IF( M1.GT.N*N2 ) + $ LDW = MAX( LDW, M1*( M1 + 1 ) ) + LDW = N1*P1 + LDW + END IF + IF( LDWORK.LT.MAX( 1, LDW ) ) + $ INFO = -34 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M1, P1 ) ).EQ.0 ) + $ RETURN +C + IF ( P1.GT.0 ) THEN +C +C Form ( I + alpha * D1 * D2 ). +C + CALL DLASET( 'F', P1, P1, ZERO, ONE, DWORK, P1 ) + CALL DGEMM ( 'No transpose', 'No transpose', P1, P1, M1, ALPHA, + $ D1, LDD1, D2, LDD2, ONE, DWORK, P1 ) +C +C Factorize this matrix. +C + CALL DGETRF( P1, P1, DWORK, P1, IWORK, INFO ) +C + IF ( INFO.NE.0 ) + $ RETURN +C +C Form E21 * D1. +C + IF ( LOVER .AND. LDD1.LE.LDD ) THEN + IF ( LDD1.LT.LDD ) THEN +C + DO 20 J = M1, 1, -1 + DO 10 I = P1, 1, -1 + D(I,J) = D1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) + END IF +C + CALL DGETRS( 'No transpose', P1, M1, DWORK, P1, IWORK, D, LDD, + $ INFO ) + IF ( N1.GT.0 ) THEN +C +C Form E21 * C1. +C + IF ( LOVER ) THEN +C +C First save C1. +C + LDW = LDW - P1*N1 + 1 + CALL DLACPY( 'F', P1, N1, C1, LDC1, DWORK(LDW), P1 ) +C + IF ( LDC1.NE.LDC ) + $ CALL DLACPY( 'F', P1, N1, DWORK(LDW), P1, C, LDC ) + ELSE + CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) + END IF +C + CALL DGETRS( 'No transpose', P1, N1, DWORK, P1, IWORK, + $ C, LDC, INFO ) + END IF +C +C Form E12 = I - alpha * D2 * ( E21 * D1 ). +C + CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) + CALL DGEMM ( 'No transpose', 'No transpose', M1, M1, P1, + $ -ALPHA, D2, LDD2, D, LDD, ONE, DWORK, LDWM1 ) +C + ELSE + CALL DLASET( 'F', M1, M1, ZERO, ONE, DWORK, LDWM1 ) + END IF +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 40 J = N1, 1, -1 + DO 30 I = N1, 1, -1 + A(I,J) = A1(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF +C + IF ( N1.GT.0 .AND. M1.GT.0 ) THEN +C +C Form B1 * E12. +C + IF ( LOVER ) THEN +C +C Use the blocks (1,2) and (2,2) of A as workspace. +C + IF ( N1*M1.LE.N*N2 ) THEN +C +C Use BLAS 3 code. +C + CALL DLACPY( 'F', N1, M1, B1, LDB1, A(1,N1+1), N1 ) + CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, + $ ONE, A(1,N1+1), N1, DWORK, LDWM1, ZERO, B, + $ LDB ) + ELSE IF ( LDB1.LT.LDB ) THEN +C + DO 60 J = M1, 1, -1 + DO 50 I = N1, 1, -1 + B(I,J) = B1(I,J) + 50 CONTINUE + 60 CONTINUE +C + IF ( M1.LE.N*N2 ) THEN +C +C Use BLAS 2 code. +C + DO 70 J = 1, N1 + CALL DCOPY( M1, B(J,1), LDB, A(1,N1+1), 1 ) + CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, + $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) + 70 CONTINUE +C + ELSE +C +C Use additional workspace. +C + DO 80 J = 1, N1 + CALL DCOPY( M1, B(J,1), LDB, DWORK(M1*M1+1), 1 ) + CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, + $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) + 80 CONTINUE +C + END IF +C + ELSE IF ( M1.LE.N*N2 ) THEN +C +C Use BLAS 2 code. +C + DO 90 J = 1, N1 + CALL DCOPY( M1, B1(J,1), LDB1, A(1,N1+1), 1 ) + CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, + $ A(1,N1+1), 1, ZERO, B(J,1), LDB ) + 90 CONTINUE +C + ELSE +C +C Use additional workspace. +C + DO 100 J = 1, N1 + CALL DCOPY( M1, B1(J,1), LDB1, DWORK(M1*M1+1), 1 ) + CALL DGEMV( 'Transpose', M1, M1, ONE, DWORK, LDWM1, + $ DWORK(M1*M1+1), 1, ZERO, B(J,1), LDB ) + 100 CONTINUE +C + END IF + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', N1, M1, M1, + $ ONE, B1, LDB1, DWORK, LDWM1, ZERO, B, LDB ) + END IF + END IF +C + IF ( N2.GT.0 ) THEN +C +C Complete matrices B and C. +C + IF ( P1.GT.0 ) THEN + CALL DGEMM ( 'No transpose', 'No transpose', N2, M1, P1, + $ ONE, B2, LDB2, D, LDD, ZERO, B(N1+1,1), LDB ) + CALL DGEMM ( 'No transpose', 'No transpose', P1, N2, M1, + $ -ALPHA, D, LDD, C2, LDC2, ZERO, C(1,N1+1), LDC + $ ) + ELSE IF ( M1.GT.0 ) THEN + CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) + END IF + END IF +C + IF ( N1.GT.0 .AND. P1.GT.0 ) THEN +C +C Form upper left quadrant of A. +C + CALL DGEMM ( 'No transpose', 'No transpose', N1, P1, M1, + $ -ALPHA, B, LDB, D2, LDD2, ZERO, DWORK, N1 ) +C + IF ( LOVER ) THEN + CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, + $ ONE, DWORK, N1, DWORK(LDW), P1, ONE, A, LDA ) + ELSE + CALL DGEMM ( 'No transpose', 'No transpose', N1, N1, P1, + $ ONE, DWORK, N1, C1, LDC1, ONE, A, LDA ) + END IF + END IF +C + IF ( N2.GT.0 ) THEN +C +C Form lower right quadrant of A. +C + CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) + IF ( M1.GT.0 ) + $ CALL DGEMM ( 'No transpose', 'No transpose', N2, N2, M1, + $ -ALPHA, B(N1+1,1), LDB, C2, LDC2, ONE, + $ A(N1+1,N1+1), LDA ) +C +C Complete the matrix A. +C + CALL DGEMM ( 'No transpose', 'No transpose', N2, N1, P1, + $ ONE, B2, LDB2, C, LDC, ZERO, A(N1+1,1), LDA ) + CALL DGEMM ( 'No transpose', 'No transpose', N1, N2, M1, + $ -ALPHA, B, LDB, C2, LDC2, ZERO, A(1,N1+1), LDA ) + END IF +C + RETURN +C *** Last line of AB05ND *** + END diff --git a/mex/sources/libslicot/AB05OD.f b/mex/sources/libslicot/AB05OD.f new file mode 100644 index 000000000..6eafa6949 --- /dev/null +++ b/mex/sources/libslicot/AB05OD.f @@ -0,0 +1,418 @@ + SUBROUTINE AB05OD( OVER, N1, M1, P1, N2, M2, ALPHA, A1, LDA1, B1, + $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, + $ C2, LDC2, D2, LDD2, N, M, A, LDA, B, LDB, C, + $ LDC, D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To obtain the state-space model (A,B,C,D) for rowwise +C concatenation (parallel inter-connection on outputs, with separate +C inputs) of two systems, each given in state-space form. +C +C ARGUMENTS +C +C Mode Parameters +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D, i.e. the same name is +C effectively used for each pair (for all pairs) +C in the routine call. In this case, setting +C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1. N1 >= 0. +C +C M1 (input) INTEGER +C The number of input variables for the first system. +C M1 >= 0. +C +C P1 (input) INTEGER +C The number of output variables from each system. P1 >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2. N2 >= 0. +C +C M2 (input) INTEGER +C The number of input variables for the second system. +C M2 >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C A coefficient multiplying the transfer-function matrix +C (or the output equation) of the second system. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) +C The leading N1-by-M1 part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P1-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P1) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) +C The leading P1-by-M1 part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P1). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) +C The leading N2-by-M2 part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading P1-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,P1) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) +C The leading P1-by-M2 part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,P1). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the connected +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C M (output) INTEGER +C The number of input variables (M1 + M2) for the connected +C system, i.e. the number of columns of B and D. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the connected system. +C The array A can overlap A1 if OVER = 'O'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) +C The leading N-by-M part of this array contains the +C input/state matrix B for the connected system. +C The array B can overlap B1 if OVER = 'O'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P1-by-N part of this array contains the +C state/output matrix C for the connected system. +C The array C can overlap C1 if OVER = 'O'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P1) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) +C The leading P1-by-M part of this array contains the +C input/output matrix D for the connected system. +C The array D can overlap D1 if OVER = 'O'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C After rowwise concatenation (parallel inter-connection with +C separate inputs) of the two systems, +C +C X1' = A1*X1 + B1*U +C Y1 = C1*X1 + D1*U +C +C X2' = A2*X2 + B2*V +C Y2 = C2*X2 + D2*V +C +C (where ' denotes differentiation with respect to time), +C +C with the output equation for the second system multiplied by a +C scalar alpha, the following state-space model will be obtained: +C +C X' = A*X + B*(U) +C (V) +C +C Y = C*X + D*(U) +C (V) +C +C where matrix A has the form ( A1 0 ), +C ( 0 A2 ) +C +C matrix B has the form ( B1 0 ), +C ( 0 B2 ) +C +C matrix C has the form ( C1 alpha*C2 ) and +C +C matrix D has the form ( D1 alpha*D2 ). +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1996. +C Supersedes Release 2.0 routine AB05CD by C.J.Benson, Kingston +C Polytechnic, United Kingdom, January 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Feb. 2004. +C +C KEYWORDS +C +C Continuous-time system, multivariable system, state-space model, +C state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, + $ N2, P1 + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) +C .. Local Scalars .. + LOGICAL LOVER + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASCL, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + N = N1 + N2 + M = M1 + M2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -1 + ELSE IF( N1.LT.0 ) THEN + INFO = -2 + ELSE IF( M1.LT.0 ) THEN + INFO = -3 + ELSE IF( P1.LT.0 ) THEN + INFO = -4 + ELSE IF( N2.LT.0 ) THEN + INFO = -5 + ELSE IF( M2.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -9 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -11 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -13 + ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN + INFO = -15 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -17 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -19 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P1 ) ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -21 + ELSE IF( LDD2.LT.MAX( 1, P1 ) ) THEN + INFO = -23 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -27 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -29 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P1 ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -31 + ELSE IF( LDD.LT.MAX( 1, P1 ) ) THEN + INFO = -33 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M, P1 ) ).EQ.0 ) + $ RETURN +C +C First form the matrix A. +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 20 J = N1, 1, -1 + DO 10 I = N1, 1, -1 + A(I,J) = A1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) + CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) + CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) + END IF +C +C Now form the matrix B. +C + IF ( LOVER .AND. LDB1.LE.LDB ) THEN + IF ( LDB1.LT.LDB ) THEN +C + DO 40 J = M1, 1, -1 + DO 30 I = N1, 1, -1 + B(I,J) = B1(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) + END IF +C + IF ( M2.GT.0 ) THEN + IF ( N2.GT.0 ) + $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) + CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) + END IF + IF ( N2.GT.0 ) + $ CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) +C +C Now form the matrix C. +C + IF ( LOVER .AND. LDC1.LE.LDC ) THEN + IF ( LDC1.LT.LDC ) THEN +C + DO 60 J = N1, 1, -1 + DO 50 I = P1, 1, -1 + C(I,J) = C1(I,J) + 50 CONTINUE + 60 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLACPY( 'F', P1, N2, C2, LDC2, C(1,N1+1), LDC ) + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, N2, C(1,N1+1), LDC, + $ INFO ) + END IF +C +C Now form the matrix D. +C + IF ( LOVER .AND. LDD1.LE.LDD ) THEN + IF ( LDD1.LT.LDD ) THEN +C + DO 80 J = M1, 1, -1 + DO 70 I = P1, 1, -1 + D(I,J) = D1(I,J) + 70 CONTINUE + 80 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) + END IF +C + IF ( M2.GT.0 ) THEN + CALL DLACPY( 'F', P1, M2, D2, LDD2, D(1,M1+1), LDD ) + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P1, M2, D(1,M1+1), LDD, + $ INFO ) + END IF +C + RETURN +C *** Last line of AB05OD *** + END diff --git a/mex/sources/libslicot/AB05PD.f b/mex/sources/libslicot/AB05PD.f new file mode 100644 index 000000000..918aed8a0 --- /dev/null +++ b/mex/sources/libslicot/AB05PD.f @@ -0,0 +1,385 @@ + SUBROUTINE AB05PD( OVER, N1, M, P, N2, ALPHA, A1, LDA1, B1, LDB1, + $ C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, C2, + $ LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the state-space model G = (A,B,C,D) corresponding to +C the sum G = G1 + alpha*G2, where G1 = (A1,B1,C1,D1) and +C G2 = (A2,B2,C2,D2). G, G1, and G2 are the transfer-function +C matrices of the corresponding state-space models. +C +C ARGUMENTS +C +C Mode Parameters +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D, i.e. the same name is +C effectively used for each pair (for all pairs) +C in the routine call. In this case, setting +C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1, the number of rows of B1 and +C the number of columns of C1. N1 >= 0. +C +C M (input) INTEGER +C The number of input variables of the two systems, i.e. the +C number of columns of matrices B1, D1, B2 and D2. M >= 0. +C +C P (input) INTEGER +C The number of output variables of the two systems, i.e. +C the number of rows of matrices C1, D1, C2 and D2. P >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2, the number of rows of B2 and +C the number of columns of C2. N2 >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The coefficient multiplying G2. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M) +C The leading N1-by-M part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M) +C The leading P-by-M part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M) +C The leading N2-by-M part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading P-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,P) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M) +C The leading P-by-M part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,P). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the resulting +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the resulting system. +C The array A can overlap A1 if OVER = 'O'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array contains the +C input/state matrix B for the resulting system. +C The array B can overlap B1 if OVER = 'O'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P-by-N part of this array contains the +C state/output matrix C for the resulting system. +C The array C can overlap C1 if OVER = 'O'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array contains the +C input/output matrix D for the resulting system. +C The array D can overlap D1 if OVER = 'O'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices of the resulting systems are determined as: +C +C ( A1 0 ) ( B1 ) +C A = ( ) , B = ( ) , +C ( 0 A2 ) ( B2 ) +C +C C = ( C1 alpha*C2 ) , D = D1 + alpha*D2 . +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, +C Belgium, Nov. 1996. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Feb. 2004. +C +C KEYWORDS +C +C Multivariable system, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO=0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, M, N, N1, N2, P + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) +C .. Local Scalars .. + LOGICAL LOVER + INTEGER I, J, N1P1 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + N = N1 + N2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -1 + ELSE IF( N1.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( N2.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -8 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -10 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -12 + ELSE IF( LDD1.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -16 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -18 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P ) ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -20 + ELSE IF( LDD2.LT.MAX( 1, P ) ) THEN + INFO = -22 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -25 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -27 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -29 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -31 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M, P ) ).EQ.0 ) + $ RETURN +C + N1P1 = N1 + 1 +C +C ( A1 0 ) +C Construct A = ( ) . +C ( 0 A2 ) +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 20 J = N1, 1, -1 + DO 10 I = N1, 1, -1 + A(I,J) = A1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1P1), LDA ) + CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1P1,1), LDA ) + CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1P1,N1P1), LDA ) + END IF +C +C ( B1 ) +C Construct B = ( ) . +C ( B2 ) +C + IF ( LOVER .AND. LDB1.LE.LDB ) THEN + IF ( LDB1.LT.LDB ) THEN +C + DO 40 J = M, 1, -1 + DO 30 I = N1, 1, -1 + B(I,J) = B1(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, M, B1, LDB1, B, LDB ) + END IF +C + IF ( N2.GT.0 ) + $ CALL DLACPY( 'F', N2, M, B2, LDB2, B(N1P1,1), LDB ) +C +C Construct C = ( C1 alpha*C2 ) . +C + IF ( LOVER .AND. LDC1.LE.LDC ) THEN + IF ( LDC1.LT.LDC ) THEN +C + DO 60 J = N1, 1, -1 + DO 50 I = P, 1, -1 + C(I,J) = C1(I,J) + 50 CONTINUE + 60 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P, N1, C1, LDC1, C, LDC ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLACPY( 'F', P, N2, C2, LDC2, C(1,N1P1), LDC ) + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P, N2, C(1,N1P1), LDC, + $ INFO ) + END IF +C +C Construct D = D1 + alpha*D2 . +C + IF ( LOVER .AND. LDD1.LE.LDD ) THEN + IF ( LDD1.LT.LDD ) THEN +C + DO 80 J = M, 1, -1 + DO 70 I = P, 1, -1 + D(I,J) = D1(I,J) + 70 CONTINUE + 80 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P, M, D1, LDD1, D, LDD ) + END IF +C + DO 90 J = 1, M + CALL DAXPY( P, ALPHA, D2(1,J), 1, D(1,J), 1 ) + 90 CONTINUE +C + RETURN +C *** Last line of AB05PD *** + END diff --git a/mex/sources/libslicot/AB05QD.f b/mex/sources/libslicot/AB05QD.f new file mode 100644 index 000000000..c9f54bcaa --- /dev/null +++ b/mex/sources/libslicot/AB05QD.f @@ -0,0 +1,419 @@ + SUBROUTINE AB05QD( OVER, N1, M1, P1, N2, M2, P2, A1, LDA1, B1, + $ LDB1, C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, + $ C2, LDC2, D2, LDD2, N, M, P, A, LDA, B, LDB, + $ C, LDC, D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To append two systems G1 and G2 in state-space form together. +C If G1 = (A1,B1,C1,D1) and G2 = (A2,B2,C2,D2) are the state-space +C models of the given two systems having the transfer-function +C matrices G1 and G2, respectively, this subroutine constructs the +C state-space model G = (A,B,C,D) which corresponds to the +C transfer-function matrix +C +C ( G1 0 ) +C G = ( ) +C ( 0 G2 ) +C +C ARGUMENTS +C +C Mode Parameters +C +C OVER CHARACTER*1 +C Indicates whether the user wishes to overlap pairs of +C arrays, as follows: +C = 'N': Do not overlap; +C = 'O': Overlap pairs of arrays: A1 and A, B1 and B, +C C1 and C, and D1 and D, i.e. the same name is +C effectively used for each pair (for all pairs) +C in the routine call. In this case, setting +C LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD +C will give maximum efficiency. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The number of state variables in the first system, i.e. +C the order of the matrix A1, the number of rows of B1 and +C the number of columns of C1. N1 >= 0. +C +C M1 (input) INTEGER +C The number of input variables in the first system, i.e. +C the number of columns of matrices B1 and D1. M1 >= 0. +C +C P1 (input) INTEGER +C The number of output variables in the first system, i.e. +C the number of rows of matrices C1 and D1. P1 >= 0. +C +C N2 (input) INTEGER +C The number of state variables in the second system, i.e. +C the order of the matrix A2, the number of rows of B2 and +C the number of columns of C2. N2 >= 0. +C +C M2 (input) INTEGER +C The number of input variables in the second system, i.e. +C the number of columns of matrices B2 and D2. M2 >= 0. +C +C P2 (input) INTEGER +C The number of output variables in the second system, i.e. +C the number of rows of matrices C2 and D2. P2 >= 0. +C +C A1 (input) DOUBLE PRECISION array, dimension (LDA1,N1) +C The leading N1-by-N1 part of this array must contain the +C state transition matrix A1 for the first system. +C +C LDA1 INTEGER +C The leading dimension of array A1. LDA1 >= MAX(1,N1). +C +C B1 (input) DOUBLE PRECISION array, dimension (LDB1,M1) +C The leading N1-by-M1 part of this array must contain the +C input/state matrix B1 for the first system. +C +C LDB1 INTEGER +C The leading dimension of array B1. LDB1 >= MAX(1,N1). +C +C C1 (input) DOUBLE PRECISION array, dimension (LDC1,N1) +C The leading P1-by-N1 part of this array must contain the +C state/output matrix C1 for the first system. +C +C LDC1 INTEGER +C The leading dimension of array C1. +C LDC1 >= MAX(1,P1) if N1 > 0. +C LDC1 >= 1 if N1 = 0. +C +C D1 (input) DOUBLE PRECISION array, dimension (LDD1,M1) +C The leading P1-by-M1 part of this array must contain the +C input/output matrix D1 for the first system. +C +C LDD1 INTEGER +C The leading dimension of array D1. LDD1 >= MAX(1,P1). +C +C A2 (input) DOUBLE PRECISION array, dimension (LDA2,N2) +C The leading N2-by-N2 part of this array must contain the +C state transition matrix A2 for the second system. +C +C LDA2 INTEGER +C The leading dimension of array A2. LDA2 >= MAX(1,N2). +C +C B2 (input) DOUBLE PRECISION array, dimension (LDB2,M2) +C The leading N2-by-M2 part of this array must contain the +C input/state matrix B2 for the second system. +C +C LDB2 INTEGER +C The leading dimension of array B2. LDB2 >= MAX(1,N2). +C +C C2 (input) DOUBLE PRECISION array, dimension (LDC2,N2) +C The leading P2-by-N2 part of this array must contain the +C state/output matrix C2 for the second system. +C +C LDC2 INTEGER +C The leading dimension of array C2. +C LDC2 >= MAX(1,P2) if N2 > 0. +C LDC2 >= 1 if N2 = 0. +C +C D2 (input) DOUBLE PRECISION array, dimension (LDD2,M2) +C The leading P2-by-M2 part of this array must contain the +C input/output matrix D2 for the second system. +C +C LDD2 INTEGER +C The leading dimension of array D2. LDD2 >= MAX(1,P2). +C +C N (output) INTEGER +C The number of state variables (N1 + N2) in the resulting +C system, i.e. the order of the matrix A, the number of rows +C of B and the number of columns of C. +C +C M (output) INTEGER +C The number of input variables (M1 + M2) in the resulting +C system, i.e. the number of columns of B and D. +C +C P (output) INTEGER +C The number of output variables (P1 + P2) of the resulting +C system, i.e. the number of rows of C and D. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N1+N2) +C The leading N-by-N part of this array contains the state +C transition matrix A for the resulting system. +C The array A can overlap A1 if OVER = 'O'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N1+N2). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M1+M2) +C The leading N-by-M part of this array contains the +C input/state matrix B for the resulting system. +C The array B can overlap B1 if OVER = 'O'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1+N2). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N1+N2) +C The leading P-by-N part of this array contains the +C state/output matrix C for the resulting system. +C The array C can overlap C1 if OVER = 'O'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P1+P2) if N1+N2 > 0. +C LDC >= 1 if N1+N2 = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M1+M2) +C The leading P-by-M part of this array contains the +C input/output matrix D for the resulting system. +C The array D can overlap D1 if OVER = 'O'. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P1+P2). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices of the resulting systems are determined as: +C +C ( A1 0 ) ( B1 0 ) +C A = ( ) , B = ( ) , +C ( 0 A2 ) ( 0 B2 ) +C +C ( C1 0 ) ( D1 0 ) +C C = ( ) , D = ( ) . +C ( 0 C2 ) ( 0 D2 ) +C +C REFERENCES +C +C None +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, +C Belgium, Nov. 1996. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Multivariable system, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO=0.0D0 ) +C .. Scalar Arguments .. + CHARACTER OVER + INTEGER INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, + $ LDC1, LDC2, LDD, LDD1, LDD2, M, M1, M2, N, N1, + $ N2, P, P1, P2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*), + $ B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*), + $ C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*) +C .. Local Scalars .. + LOGICAL LOVER + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + LOVER = LSAME( OVER, 'O' ) + N = N1 + N2 + M = M1 + M2 + P = P1 + P2 + INFO = 0 +C +C Test the input scalar arguments. +C + IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN + INFO = -1 + ELSE IF( N1.LT.0 ) THEN + INFO = -2 + ELSE IF( M1.LT.0 ) THEN + INFO = -3 + ELSE IF( P1.LT.0 ) THEN + INFO = -4 + ELSE IF( N2.LT.0 ) THEN + INFO = -5 + ELSE IF( M2.LT.0 ) THEN + INFO = -6 + ELSE IF( P2.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN + INFO = -9 + ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN + INFO = -11 + ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P1 ) ) .OR. + $ ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN + INFO = -13 + ELSE IF( LDD1.LT.MAX( 1, P1 ) ) THEN + INFO = -15 + ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN + INFO = -17 + ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN + INFO = -19 + ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P2 ) ) .OR. + $ ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN + INFO = -21 + ELSE IF( LDD2.LT.MAX( 1, P2 ) ) THEN + INFO = -23 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -28 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -30 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -32 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -34 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M, P ) ).EQ.0 ) + $ RETURN +C ( A1 0 ) +C Construct A = ( ) . +C ( 0 A2 ) +C + IF ( LOVER .AND. LDA1.LE.LDA ) THEN + IF ( LDA1.LT.LDA ) THEN +C + DO 20 J = N1, 1, -1 + DO 10 I = N1, 1, -1 + A(I,J) = A1(I,J) + 10 CONTINUE + 20 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA ) + END IF +C + IF ( N2.GT.0 ) THEN + CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1+1), LDA ) + CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1+1,1), LDA ) + CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1+1,N1+1), LDA ) + END IF +C +C ( B1 0 ) +C Construct B = ( ) . +C ( 0 B2 ) +C + IF ( LOVER .AND. LDB1.LE.LDB ) THEN + IF ( LDB1.LT.LDB ) THEN +C + DO 40 J = M1, 1, -1 + DO 30 I = N1, 1, -1 + B(I,J) = B1(I,J) + 30 CONTINUE + 40 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', N1, M1, B1, LDB1, B, LDB ) + END IF +C + IF ( M2.GT.0 ) + $ CALL DLASET( 'F', N1, M2, ZERO, ZERO, B(1,M1+1), LDB ) + IF ( N2.GT.0 ) THEN + CALL DLASET( 'F', N2, M1, ZERO, ZERO, B(N1+1,1), LDB ) + IF ( M2.GT.0 ) + $ CALL DLACPY( 'F', N2, M2, B2, LDB2, B(N1+1,M1+1), LDB ) + END IF +C +C ( C1 0 ) +C Construct C = ( ) . +C ( 0 C2 ) +C + IF ( LOVER .AND. LDC1.LE.LDC ) THEN + IF ( LDC1.LT.LDC ) THEN +C + DO 60 J = N1, 1, -1 + DO 50 I = P1, 1, -1 + C(I,J) = C1(I,J) + 50 CONTINUE + 60 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, N1, C1, LDC1, C, LDC ) + END IF +C + IF ( N2.GT.0 ) + $ CALL DLASET( 'F', P1, N2, ZERO, ZERO, C(1,N1+1), LDC ) + IF ( P2.GT.0 ) THEN + IF ( N1.GT.0 ) + $ CALL DLASET( 'F', P2, N1, ZERO, ZERO, C(P1+1,1), LDC ) + IF ( N2.GT.0 ) + $ CALL DLACPY( 'F', P2, N2, C2, LDC2, C(P1+1,N1+1), LDC ) + END IF +C +C ( D1 0 ) +C Construct D = ( ) . +C ( 0 D2 ) +C + IF ( LOVER .AND. LDD1.LE.LDD ) THEN + IF ( LDD1.LT.LDD ) THEN +C + DO 80 J = M1, 1, -1 + DO 70 I = P1, 1, -1 + D(I,J) = D1(I,J) + 70 CONTINUE + 80 CONTINUE +C + END IF + ELSE + CALL DLACPY( 'F', P1, M1, D1, LDD1, D, LDD ) + END IF +C + IF ( M2.GT.0 ) + $ CALL DLASET( 'F', P1, M2, ZERO, ZERO, D(1,M1+1), LDD ) + IF ( P2.GT.0 ) THEN + CALL DLASET( 'F', P2, M1, ZERO, ZERO, D(P1+1,1), LDD ) + IF ( M2.GT.0 ) + $ CALL DLACPY( 'F', P2, M2, D2, LDD2, D(P1+1,M1+1), LDD ) + END IF +C + RETURN +C *** Last line of AB05QD *** + END diff --git a/mex/sources/libslicot/AB05RD.f b/mex/sources/libslicot/AB05RD.f new file mode 100644 index 000000000..4592f93d3 --- /dev/null +++ b/mex/sources/libslicot/AB05RD.f @@ -0,0 +1,393 @@ + SUBROUTINE AB05RD( FBTYPE, JOBD, N, M, P, MV, PZ, ALPHA, BETA, A, + $ LDA, B, LDB, C, LDC, D, LDD, F, LDF, K, LDK, + $ G, LDG, H, LDH, RCOND, BC, LDBC, CC, LDCC, + $ DC, LDDC, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct for a given state space system (A,B,C,D) the closed- +C loop system (Ac,Bc,Cc,Dc) corresponding to the mixed output and +C state feedback control law +C +C u = alpha*F*y + beta*K*x + G*v +C z = H*y. +C +C ARGUMENTS +C +C Mode Parameters +C +C FBTYPE CHARACTER*1 +C Specifies the type of the feedback law as follows: +C = 'I': Unitary output feedback (F = I); +C = 'O': General output feedback. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears +C in the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of state vector x, i.e. the order of the +C matrix A, the number of rows of B and the number of +C columns of C. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector u, i.e. the number of +C columns of matrices B and D, and the number of rows of F. +C M >= 0. +C +C P (input) INTEGER +C The dimension of output vector y, i.e. the number of rows +C of matrices C and D, and the number of columns of F. +C P >= 0 and P = M if FBTYPE = 'I'. +C +C MV (input) INTEGER +C The dimension of the new input vector v, i.e. the number +C of columns of matrix G. MV >= 0. +C +C PZ (input) INTEGER. +C The dimension of the new output vector z, i.e. the number +C of rows of matrix H. PZ >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The coefficient alpha in the output feedback law. +C +C BETA (input) DOUBLE PRECISION. +C The coefficient beta in the state feedback law. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state transition matrix A. +C On exit, the leading N-by-N part of this array contains +C the state matrix Ac of the closed-loop system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the intermediary input matrix B1 (see METHOD). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading P-by-N part of this array contains +C the intermediary output matrix C1+BETA*D1*K (see METHOD). +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the system direct input/output +C transmission matrix D. +C On exit, the leading P-by-M part of this array contains +C the intermediary direct input/output transmission matrix +C D1 (see METHOD). +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C F (input) DOUBLE PRECISION array, dimension (LDF,P) +C If FBTYPE = 'O', the leading M-by-P part of this array +C must contain the output feedback matrix F. +C If FBTYPE = 'I', then the feedback matrix is assumed to be +C an M x M order identity matrix. +C The array F is not referenced if FBTYPE = 'I' or +C ALPHA = 0. +C +C LDF INTEGER +C The leading dimension of array F. +C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. +C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. +C +C K (input) DOUBLE PRECISION array, dimension (LDK,N) +C The leading M-by-N part of this array must contain the +C state feedback matrix K. +C The array K is not referenced if BETA = 0. +C +C LDK INTEGER +C The leading dimension of the array K. +C LDK >= MAX(1,M) if BETA <> 0. +C LDK >= 1 if BETA = 0. +C +C G (input) DOUBLE PRECISION array, dimension (LDG,MV) +C The leading M-by-MV part of this array must contain the +C system input scaling matrix G. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,M). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,P) +C The leading PZ-by-P part of this array must contain the +C system output scaling matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= MAX(1,PZ). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal condition number of the matrix +C I - alpha*D*F. +C +C BC (output) DOUBLE PRECISION array, dimension (LDBC,MV) +C The leading N-by-MV part of this array contains the input +C matrix Bc of the closed-loop system. +C +C LDBC INTEGER +C The leading dimension of array BC. LDBC >= MAX(1,N). +C +C CC (output) DOUBLE PRECISION array, dimension (LDCC,N) +C The leading PZ-by-N part of this array contains the +C system output matrix Cc of the closed-loop system. +C +C LDCC INTEGER +C The leading dimension of array CC. +C LDCC >= MAX(1,PZ) if N > 0. +C LDCC >= 1 if N = 0. +C +C DC (output) DOUBLE PRECISION array, dimension (LDDC,MV) +C If JOBD = 'D', the leading PZ-by-MV part of this array +C contains the direct input/output transmission matrix Dc +C of the closed-loop system. +C The array DC is not referenced if JOBD = 'Z'. +C +C LDDC INTEGER +C The leading dimension of array DC. +C LDDC >= MAX(1,PZ) if JOBD = 'D'. +C LDDC >= 1 if JOBD = 'Z'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= MAX(1,2*P) if JOBD = 'D'. +C LIWORK >= 1 if JOBD = 'Z'. +C IWORK is not referenced if JOBD = 'Z'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= wspace, where +C wspace = MAX( 1, M, P*MV, P*P + 4*P ) if JOBD = 'D', +C wspace = MAX( 1, M ) if JOBD = 'Z'. +C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix I - alpha*D*F is numerically singular. +C +C METHOD +C +C The matrices of the closed-loop system have the expressions: +C +C Ac = A1 + beta*B1*K, Bc = B1*G, +C Cc = H*(C1 + beta*D1*K), Dc = H*D1*G, +C +C where +C +C A1 = A + alpha*B*F*E*C, B1 = B + alpha*B*F*E*D, +C C1 = E*C, D1 = E*D, +C +C with E = (I - alpha*D*F)**-1. +C +C NUMERICAL ASPECTS +C +C The accuracy of computations basically depends on the conditioning +C of the matrix I - alpha*D*F. If RCOND is very small, it is likely +C that the computed results are inaccurate. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, +C Belgium, Nov. 1996. +C +C REVISIONS +C +C January 14, 1997, February 18, 1998. +C V. Sima, Research Institute for Informatics, Bucharest, July 2003, +C Jan. 2005. +C +C KEYWORDS +C +C Multivariable system, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FBTYPE, JOBD + INTEGER INFO, LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, + $ LDF, LDG, LDH, LDK, LDWORK, M, MV, N, P, PZ + DOUBLE PRECISION ALPHA, BETA, RCOND +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), BC(LDBC,*), C(LDC,*), + $ CC(LDCC,*), D(LDD,*), DC(LDDC,*), DWORK(*), + $ F(LDF,*), G(LDG,*), H(LDH,*), K(LDK,*) +C .. Local Scalars .. + LOGICAL LJOBD, OUTPF, UNITF + INTEGER LDWP +C .. External functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External subroutines .. + EXTERNAL AB05SD, DGEMM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + UNITF = LSAME( FBTYPE, 'I' ) + OUTPF = LSAME( FBTYPE, 'O' ) + LJOBD = LSAME( JOBD, 'D' ) +C + INFO = 0 +C + IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN + INFO = -5 + ELSE IF( MV.LT.0 ) THEN + INFO = -6 + ELSE IF( PZ.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -15 + ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN + INFO = -17 + ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) + $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN + INFO = -19 + ELSE IF( ( BETA.NE.ZERO .AND. LDK.LT.MAX( 1, M ) ) .OR. + $ ( BETA.EQ.ZERO .AND. LDK.LT.1 ) ) THEN + INFO = -21 + ELSE IF( LDG.LT.MAX( 1, M ) ) THEN + INFO = -23 + ELSE IF( LDH.LT.MAX( 1, PZ ) ) THEN + INFO = -25 + ELSE IF( LDBC.LT.MAX( 1, N ) ) THEN + INFO = -28 + ELSE IF( ( N.GT.0 .AND. LDCC.LT.MAX( 1, PZ ) ) .OR. + $ ( N.EQ.0 .AND. LDCC.LT.1 ) ) THEN + INFO = -30 + ELSE IF( ( ( LJOBD .AND. LDDC.LT.MAX( 1, PZ ) ) .OR. + $ ( .NOT.LJOBD .AND. LDDC.LT.1 ) ) ) THEN + INFO = -32 + ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*MV, P*P + 4*P ) ) + $ .OR. ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN + INFO = -35 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MIN( M, P ), MIN( MV, PZ ) ).EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +C +C Apply the partial output feedback u = alpha*F*y + v1 +C + CALL AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, C, + $ LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, LDWORK, + $ INFO ) + IF ( INFO.NE.0 ) RETURN +C +C Apply the partial state feedback v1 = beta*K*x + v2. +C +C Compute Ac = A1 + beta*B1*K and C1 <- C1 + beta*D1*K. +C + IF( BETA.NE.ZERO .AND. N.GT.0 ) THEN + CALL DGEMM( 'N', 'N', N, N, M, BETA, B, LDB, K, LDK, ONE, A, + $ LDA ) + IF( LJOBD ) + $ CALL DGEMM( 'N', 'N', P, N, M, BETA, D, LDD, K, LDK, ONE, + $ C, LDC ) + END IF +C +C Apply the input and output conversions v2 = G*v, z = H*y. +C +C Compute Bc = B1*G. +C + CALL DGEMM( 'N', 'N', N, MV, M, ONE, B, LDB, G, LDG, ZERO, BC, + $ LDBC ) +C +C Compute Cc = H*C1. +C + IF( N.GT.0 ) + $ CALL DGEMM( 'N', 'N', PZ, N, P, ONE, H, LDH, C, LDC, ZERO, CC, + $ LDCC ) +C +C Compute Dc = H*D1*G. +C + IF( LJOBD ) THEN + LDWP = MAX( 1, P ) + CALL DGEMM( 'N', 'N', P, MV, M, ONE, D, LDD, G, LDG, ZERO, + $ DWORK, LDWP ) + CALL DGEMM( 'N', 'N', PZ, MV, P, ONE, H, LDH, DWORK, LDWP, + $ ZERO, DC, LDDC ) + END IF +C + RETURN +C *** Last line of AB05RD *** + END diff --git a/mex/sources/libslicot/AB05SD.f b/mex/sources/libslicot/AB05SD.f new file mode 100644 index 000000000..7cc57b5c7 --- /dev/null +++ b/mex/sources/libslicot/AB05SD.f @@ -0,0 +1,371 @@ + SUBROUTINE AB05SD( FBTYPE, JOBD, N, M, P, ALPHA, A, LDA, B, LDB, + $ C, LDC, D, LDD, F, LDF, RCOND, IWORK, DWORK, + $ LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct for a given state space system (A,B,C,D) the closed- +C loop system (Ac,Bc,Cc,Dc) corresponding to the output feedback +C control law +C +C u = alpha*F*y + v. +C +C ARGUMENTS +C +C Mode Parameters +C +C FBTYPE CHARACTER*1 +C Specifies the type of the feedback law as follows: +C = 'I': Unitary output feedback (F = I); +C = 'O': General output feedback. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e. the order of the +C matrix A, the number of rows of B and the number of +C columns of C. N >= 0. +C +C M (input) INTEGER +C The number of input variables, i.e. the number of columns +C of matrices B and D, and the number of rows of F. M >= 0. +C +C P (input) INTEGER +C The number of output variables, i.e. the number of rows of +C matrices C and D, and the number of columns of F. P >= 0 +C and P = M if FBTYPE = 'I'. +C +C ALPHA (input) DOUBLE PRECISION +C The coefficient alpha in the output feedback law. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state transition matrix A. +C On exit, the leading N-by-N part of this array contains +C the state matrix Ac of the closed-loop system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the input matrix Bc of the closed-loop system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading P-by-N part of this array contains +C the output matrix Cc of the closed-loop system. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the system direct input/output transmission +C matrix D. +C On exit, if JOBD = 'D', the leading P-by-M part of this +C array contains the direct input/output transmission +C matrix Dc of the closed-loop system. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C F (input) DOUBLE PRECISION array, dimension (LDF,P) +C If FBTYPE = 'O', the leading M-by-P part of this array +C must contain the output feedback matrix F. +C If FBTYPE = 'I', then the feedback matrix is assumed to be +C an M x M order identity matrix. +C The array F is not referenced if FBTYPE = 'I' or +C ALPHA = 0. +C +C LDF INTEGER +C The leading dimension of array F. +C LDF >= MAX(1,M) if FBTYPE = 'O' and ALPHA <> 0. +C LDF >= 1 if FBTYPE = 'I' or ALPHA = 0. +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal condition number of the matrix +C I - alpha*D*F. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= MAX(1,2*P) if JOBD = 'D'. +C LIWORK >= 1 if JOBD = 'Z'. +C IWORK is not referenced if JOBD = 'Z'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= wspace, where +C wspace = MAX( 1, M, P*P + 4*P ) if JOBD = 'D', +C wspace = MAX( 1, M ) if JOBD = 'Z'. +C For best performance, LDWORK >= MAX( wspace, N*M, N*P ). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix I - alpha*D*F is numerically singular. +C +C METHOD +C +C The matrices of the closed-loop system have the expressions: +C +C Ac = A + alpha*B*F*E*C, Bc = B + alpha*B*F*E*D, +C Cc = E*C, Dc = E*D, +C +C where E = (I - alpha*D*F)**-1. +C +C NUMERICAL ASPECTS +C +C The accuracy of computations basically depends on the conditioning +C of the matrix I - alpha*D*F. If RCOND is very small, it is likely +C that the computed results are inaccurate. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Research Establishment, +C Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven, +C Belgium, Nov. 1996. +C +C REVISIONS +C +C January 14, 1997. +C V. Sima, Research Institute for Informatics, Bucharest, July 2003. +C +C KEYWORDS +C +C Multivariable system, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FBTYPE, JOBD + INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDWORK, M, N, P + DOUBLE PRECISION ALPHA, RCOND +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), F(LDF,*) +C .. Local Scalars .. + LOGICAL LJOBD, OUTPF, UNITF + INTEGER I, IW, LDWN, LDWP + DOUBLE PRECISION ENORM +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEMV, DGETRF, + $ DGETRS, DLACPY, DLASCL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + UNITF = LSAME( FBTYPE, 'I' ) + OUTPF = LSAME( FBTYPE, 'O' ) + LJOBD = LSAME( JOBD, 'D' ) + LDWN = MAX( 1, N ) + LDWP = MAX( 1, P ) +C + INFO = 0 +C + IF( .NOT.UNITF .AND. .NOT.OUTPF ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 .OR. UNITF.AND.P.NE.M ) THEN + INFO = -5 + ELSE IF( LDA.LT.LDWN ) THEN + INFO = -7 + ELSE IF( LDB.LT.LDWN ) THEN + INFO = -9 + ELSE IF( ( N.GT.0 .AND. LDC.LT.LDWP ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -11 + ELSE IF( ( LJOBD .AND. LDD.LT.LDWP ) .OR. + $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN + INFO = -13 + ELSE IF( ( OUTPF .AND. ALPHA.NE.ZERO .AND. LDF.LT.MAX( 1, M ) ) + $ .OR. ( ( UNITF .OR. ALPHA.EQ.ZERO ) .AND. LDF.LT.1 ) ) THEN + INFO = -16 + ELSE IF( ( LJOBD .AND. LDWORK.LT.MAX( 1, M, P*P + 4*P ) ) .OR. + $ ( .NOT.LJOBD .AND. LDWORK.LT.MAX( 1, M ) ) ) THEN + INFO = -20 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB05SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + RCOND = ONE + IF ( MAX( N, MIN( M, P ) ).EQ.0 .OR. ALPHA.EQ.ZERO ) + $ RETURN +C + IF (LJOBD) THEN + IW = P*P + 1 +C +C Compute I - alpha*D*F. +C + IF( UNITF) THEN + CALL DLACPY( 'F', P, P, D, LDD, DWORK, LDWP ) + IF ( ALPHA.NE.-ONE ) + $ CALL DLASCL( 'G', 0, 0, ONE, -ALPHA, P, P, DWORK, LDWP, + $ INFO ) + ELSE + CALL DGEMM( 'N', 'N', P, P, M, -ALPHA, D, LDD, F, LDF, ZERO, + $ DWORK, LDWP ) + END IF +C + DUMMY(1) = ONE + CALL DAXPY( P, ONE, DUMMY, 0, DWORK, P+1 ) +C +C Compute Cc = E*C, Dc = E*D, where E = (I - alpha*D*F)**-1. +C + ENORM = DLANGE( '1', P, P, DWORK, LDWP, DWORK(IW) ) + CALL DGETRF( P, P, DWORK, LDWP, IWORK, INFO ) + IF( INFO.GT.0 ) THEN +C +C Error return. +C + RCOND = ZERO + INFO = 1 + RETURN + END IF + CALL DGECON( '1', P, DWORK, LDWP, ENORM, RCOND, DWORK(IW), + $ IWORK(P+1), INFO ) + IF( RCOND.LE.DLAMCH('E') ) THEN +C +C Error return. +C + INFO = 1 + RETURN + END IF +C + IF( N.GT.0 ) + $ CALL DGETRS( 'N', P, N, DWORK, LDWP, IWORK, C, LDC, INFO ) + CALL DGETRS( 'N', P, M, DWORK, LDWP, IWORK, D, LDD, INFO ) + END IF +C + IF ( N.EQ.0 ) + $ RETURN +C +C Compute Ac = A + alpha*B*F*Cc and Bc = B + alpha*B*F*Dc. +C + IF( UNITF ) THEN + CALL DGEMM( 'N', 'N', N, N, M, ALPHA, B, LDB, C, LDC, ONE, A, + $ LDA ) + IF( LJOBD ) THEN +C + IF( LDWORK.LT.N*M ) THEN +C +C Not enough working space for using DGEMM. +C + DO 10 I = 1, N + CALL DCOPY( P, B(I,1), LDB, DWORK, 1 ) + CALL DGEMV( 'T', P, P, ALPHA, D, LDD, DWORK, 1, ONE, + $ B(I,1), LDB ) + 10 CONTINUE +C + ELSE + CALL DLACPY( 'F', N, M, B, LDB, DWORK, LDWN ) + CALL DGEMM( 'N', 'N', N, P, M, ALPHA, DWORK, LDWN, D, + $ LDD, ONE, B, LDB ) + END IF + END IF + ELSE +C + IF( LDWORK.LT.N*P ) THEN +C +C Not enough working space for using DGEMM. +C + DO 20 I = 1, N + CALL DGEMV( 'N', M, P, ALPHA, F, LDF, C(1,I), 1, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'N', N, M, ONE, B, LDB, DWORK, 1, ONE, + $ A(1,I), 1 ) + 20 CONTINUE +C + IF( LJOBD ) THEN +C + DO 30 I = 1, N + CALL DGEMV( 'T', M, P, ALPHA, F, LDF, B(I,1), LDB, + $ ZERO, DWORK, 1 ) + CALL DGEMV( 'T', P, M, ONE, D, LDD, DWORK, 1, ONE, + $ B(I,1), LDB ) + 30 CONTINUE +C + END IF + ELSE +C + CALL DGEMM( 'N', 'N', N, P, M, ALPHA, B, LDB, F, LDF, + $ ZERO, DWORK, LDWN ) + CALL DGEMM( 'N', 'N', N, N, P, ONE, DWORK, LDWN, C, LDC, + $ ONE, A, LDA ) + IF( LJOBD ) + $ CALL DGEMM( 'N', 'N', N, M, P, ONE, DWORK, LDWN, D, LDD, + $ ONE, B, LDB ) + END IF + END IF +C + RETURN +C *** Last line of AB05SD *** + END diff --git a/mex/sources/libslicot/AB07MD.f b/mex/sources/libslicot/AB07MD.f new file mode 100644 index 000000000..da49e2df7 --- /dev/null +++ b/mex/sources/libslicot/AB07MD.f @@ -0,0 +1,224 @@ + SUBROUTINE AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the dual of a given state-space representation. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the dual state dynamics matrix A'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, the leading N-by-P part of this array contains +C the dual input/state matrix C'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, the leading M-by-N part of this array contains +C the dual state/output matrix B'. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,MAX(M,P)) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the original direct transmission +C matrix D. +C On exit, if JOBD = 'D', the leading M-by-P part of this +C array contains the dual direct transmission matrix D'. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,M,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If the given state-space representation is the M-input/P-output +C (A,B,C,D), its dual is simply the P-input/M-output (A',C',B',D'). +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine AB07AD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Dual system, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER JOBD + INTEGER INFO, LDA, LDB, LDC, LDD, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*) +C .. Local Scalars .. + LOGICAL LJOBD + INTEGER J, MINMP, MPLIM +C .. External functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External subroutines .. + EXTERNAL DCOPY, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LJOBD = LSAME( JOBD, 'D' ) + MPLIM = MAX( M, P ) + MINMP = MIN( M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, MPLIM ) ) .OR. + $ ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN + INFO = -10 + ELSE IF( ( LJOBD .AND. LDD.LT.MAX( 1, MPLIM ) ) .OR. + $ ( .NOT.LJOBD .AND. LDD.LT.1 ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB07MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, MINMP ).EQ.0 ) + $ RETURN +C + IF ( N.GT.0 ) THEN +C +C Transpose A, if non-scalar. +C + DO 10 J = 1, N - 1 + CALL DSWAP( N-J, A(J+1,J), 1, A(J,J+1), LDA ) + 10 CONTINUE +C +C Replace B by C' and C by B'. +C + DO 20 J = 1, MPLIM + IF ( J.LE.MINMP ) THEN + CALL DSWAP( N, B(1,J), 1, C(J,1), LDC ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( N, B(1,J), 1, C(J,1), LDC ) + ELSE + CALL DCOPY( N, C(J,1), LDC, B(1,J), 1 ) + END IF + 20 CONTINUE +C + END IF +C + IF ( LJOBD .AND. MINMP.GT.0 ) THEN +C +C Transpose D, if non-scalar. +C + DO 30 J = 1, MPLIM + IF ( J.LT.MINMP ) THEN + CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) + ELSE IF ( J.GT.M ) THEN + CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) + END IF + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of AB07MD *** + END diff --git a/mex/sources/libslicot/AB07ND.f b/mex/sources/libslicot/AB07ND.f new file mode 100644 index 000000000..86b26d27a --- /dev/null +++ b/mex/sources/libslicot/AB07ND.f @@ -0,0 +1,303 @@ + SUBROUTINE AB07ND( N, M, A, LDA, B, LDB, C, LDC, D, LDD, RCOND, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the inverse (Ai,Bi,Ci,Di) of a given system (A,B,C,D). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs and outputs. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state matrix A of the original system. +C On exit, the leading N-by-N part of this array contains +C the state matrix Ai of the inverse system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the original system. +C On exit, the leading N-by-M part of this array contains +C the input matrix Bi of the inverse system. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the output matrix C of the original system. +C On exit, the leading M-by-N part of this array contains +C the output matrix Ci of the inverse system. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,M). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading M-by-M part of this array must +C contain the feedthrough matrix D of the original system. +C On exit, the leading M-by-M part of this array contains +C the feedthrough matrix Di of the inverse system. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,M). +C +C RCOND (output) DOUBLE PRECISION +C The estimated reciprocal condition number of the +C feedthrough matrix D of the original system. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or M+1, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,4*M). +C For good performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: the matrix D is exactly singular; the (i,i) diagonal +C element is zero, i <= M; RCOND was set to zero; +C = M+1: the matrix D is numerically singular, i.e., RCOND +C is less than the relative machine precision, EPS +C (see LAPACK Library routine DLAMCH). The +C calculations have been completed, but the results +C could be very inaccurate. +C +C METHOD +C +C The matrices of the inverse system are computed with the formulas: +C -1 -1 -1 -1 +C Ai = A - B*D *C, Bi = -B*D , Ci = D *C, Di = D . +C +C NUMERICAL ASPECTS +C +C The accuracy depends mainly on the condition number of the matrix +C D to be inverted. The estimated reciprocal condition number is +C returned in RCOND. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. +C D. Sima, University of Bucharest, April 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C Based on the routine SYSINV, A. Varga, 1992. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. +C +C KEYWORDS +C +C Inverse system, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION RCOND + INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION DNORM + INTEGER BL, CHUNK, I, IERR, J, MAXWRK + LOGICAL BLAS3, BLOCK +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + INTEGER ILAENV + EXTERNAL DLAMCH, DLANGE, ILAENV +C .. External Subroutines .. + EXTERNAL DCOPY, DGECON, DGEMM, DGEMV, DGETRF, DGETRI, + $ DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 4*M ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB07ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) THEN + RCOND = ONE + DWORK(1) = ONE + RETURN + END IF +C +C Factorize D. +C + CALL DGETRF( M, M, D, LDD, IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + RCOND = ZERO + RETURN + END IF +C +C Compute the reciprocal condition number of the matrix D. +C Workspace: need 4*M. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DNORM = DLANGE( '1-norm', M, M, D, LDD, DWORK ) + CALL DGECON( '1-norm', M, D, LDD, DNORM, RCOND, DWORK, IWORK(M+1), + $ IERR ) + IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) + $ INFO = M + 1 +C -1 +C Compute Di = D . +C Workspace: need M; +C prefer M*NB. +C + MAXWRK = MAX( 4*M, M*ILAENV( 1, 'DGETRI', ' ', M, -1, -1, -1 ) ) + CALL DGETRI( M, D, LDD, IWORK, DWORK, LDWORK, IERR ) + IF ( N.GT.0 ) THEN + CHUNK = LDWORK / M + BLAS3 = CHUNK.GE.N .AND. M.GT.1 + BLOCK = MIN( CHUNK, M ).GT.1 +C -1 +C Compute Bi = -B*D . +C + IF ( BLAS3 ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, M, -ONE, + $ DWORK, N, D, LDD, ZERO, B, LDB ) +C + ELSE IF( BLOCK ) THEN +C +C Use as many rows of B as possible. +C + DO 10 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DLACPY( 'Full', BL, M, B(I,1), LDB, DWORK, BL ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, -ONE, + $ DWORK, BL, D, LDD, ZERO, B(I,1), LDB ) + 10 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 20 I = 1, N + CALL DCOPY( M, B(I,1), LDB, DWORK, 1 ) + CALL DGEMV( 'Transpose', M, M, -ONE, D, LDD, DWORK, 1, + $ ZERO, B(I,1), LDB ) + 20 CONTINUE +C + END IF +C +C Compute Ai = A + Bi*C. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, LDB, + $ C, LDC, ONE, A, LDA ) +C -1 +C Compute C <-- D *C. +C + IF ( BLAS3 ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, + $ D, LDD, DWORK, M, ZERO, C, LDC ) +C + ELSE IF( BLOCK ) THEN +C +C Use as many columns of C as possible. +C + DO 30 J = 1, N, CHUNK + BL = MIN( N-J+1, CHUNK ) + CALL DLACPY( 'Full', M, BL, C(1,J), LDC, DWORK, M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, + $ D, LDD, DWORK, M, ZERO, C(1,J), LDC ) + 30 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 40 J = 1, N + CALL DCOPY( M, C(1,J), 1, DWORK, 1 ) + CALL DGEMV( 'NoTranspose', M, M, ONE, D, LDD, DWORK, 1, + $ ZERO, C(1,J), 1 ) + 40 CONTINUE +C + END IF + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK(1) = DBLE( MAX( MAXWRK, N*M ) ) + RETURN +C +C *** Last line of AB07ND *** + END diff --git a/mex/sources/libslicot/AB08MD.f b/mex/sources/libslicot/AB08MD.f new file mode 100644 index 000000000..bd801a617 --- /dev/null +++ b/mex/sources/libslicot/AB08MD.f @@ -0,0 +1,299 @@ + SUBROUTINE AB08MD( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ RANK, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the normal rank of the transfer-function matrix of a +C state-space model (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C RANK (output) INTEGER +C The normal rank of the transfer-function matrix. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*N+MAX(M,P)+1) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= (N+P)*(N+M) + +C MAX( MIN(P,M) + MAX(3*M-1,N), 1, +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ) +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) +C (D C) +C +C to one with the same invariant zeros and with D of full row rank. +C The normal rank of the transfer-function matrix is the rank of D. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C Dec. 2003, Jan. 2009, Mar. 2009, Apr. 2009. +C +C KEYWORDS +C +C Multivariable system, orthogonal transformation, +C structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER INFO, LDA, LDB, LDC, LDD, LDWORK, M, N, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, KW, MU, NB, NINFZ, NKROL, NM, NP, NU, RO, + $ SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL AB08NX, DLACPY, TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + NP = N + P + NM = N + M + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LDWORK.EQ.-1 ) + WRKOPT = NP*NM +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE + KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, + $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) + IF( LQUERY ) THEN + SVLMAX = ZERO + NINFZ = 0 + CALL AB08NX( N, M, P, P, 0, SVLMAX, DWORK, MAX( 1, NP ), + $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, + $ DWORK, -1, INFO ) + WRKOPT = MAX( KW, WRKOPT + INT( DWORK(1) ) ) + ELSE IF( LDWORK.LT.KW ) THEN + INFO = -17 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08MD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, P ).EQ.0 ) THEN + RANK = 0 + DWORK(1) = ONE + RETURN + END IF +C + DO 10 I = 1, 2*N+1 + IWORK(I) = 0 + 10 CONTINUE +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C Workspace: need (N+P)*(N+M). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NP ) + CALL DLACPY( 'Full', P, M, D, LDD, DWORK(N+1), NP ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(NP*M+1), NP ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(NP*M+N+1), NP ) +C +C If required, balance the compound matrix (default MAXRED). +C Workspace: need N. +C + KW = WRKOPT + 1 + IF ( LEQUIL ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', N, M, P, MAXRED, DWORK(NP*M+1), NP, DWORK, + $ NP, DWORK(NP*M+N+1), NP, DWORK(KW), INFO ) + WRKOPT = WRKOPT + N + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = DLANGE( 'Frobenius', NP, NM, DWORK, NP, DWORK(KW) ) +C +C Reduce this system to one with the same invariant zeros and with +C D full row rank MU (the normal rank of the original system). +C Real workspace: need (N+P)*(N+M) + +C MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C Integer workspace: 2*N+MAX(M,P)+1. +C + RO = P + SIGMA = 0 + NINFZ = 0 + CALL AB08NX( N, M, P, RO, SIGMA, SVLMAX, DWORK, NP, NINFZ, IWORK, + $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), + $ DWORK(KW), LDWORK-KW+1, INFO ) + RANK = MU +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + RETURN +C *** Last line of AB08MD *** + END diff --git a/mex/sources/libslicot/AB08MZ.f b/mex/sources/libslicot/AB08MZ.f new file mode 100644 index 000000000..89d8005e7 --- /dev/null +++ b/mex/sources/libslicot/AB08MZ.f @@ -0,0 +1,303 @@ + SUBROUTINE AB08MZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ RANK, TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the normal rank of the transfer-function matrix of a +C state-space model (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) COMPLEX*16 array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) COMPLEX*16 array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) COMPLEX*16 array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) COMPLEX*16 array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C RANK (output) INTEGER +C The normal rank of the transfer-function matrix. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*N+MAX(M,P)+1) +C +C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= (N+P)*(N+M) + MAX(MIN(P,M) + MAX(3*M-1,N), 1, +C MIN(P,N) + MAX(3*P-1,N+P,N+M)) +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine reduces the (N+P)-by-(M+N) compound matrix (B A) +C (D C) +C +C to one with the same invariant zeros and with D of full row rank. +C The normal rank of the transfer-function matrix is the rank of D. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Dec. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Multivariable system, unitary transformation, +C structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER INFO, LDA, LDB, LDC, LDD, LZWORK, M, N, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), ZWORK(*) + DOUBLE PRECISION DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, KW, MU, NB, NINFZ, NKROL, NM, NP, NU, RO, + $ SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZLACPY +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + NP = N + P + NM = N + M + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LZWORK.EQ.-1 ) + WRKOPT = NP*NM +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE + KW = WRKOPT + MAX( MIN( P, M ) + MAX( 3*M-1, N ), 1, + $ MIN( P, N ) + MAX( 3*P-1, NP, NM ) ) + IF( LQUERY ) THEN + SVLMAX = ZERO + NINFZ = 0 + CALL AB8NXZ( N, M, P, P, 0, SVLMAX, ZWORK, MAX( 1, NP ), + $ NINFZ, IWORK, IWORK, MU, NU, NKROL, TOL, IWORK, + $ DWORK, ZWORK, -1, INFO ) + WRKOPT = MAX( KW, WRKOPT + INT( ZWORK(1) ) ) + ELSE IF( LZWORK.LT.KW ) THEN + INFO = -17 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08MZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, P ).EQ.0 ) THEN + RANK = 0 + ZWORK(1) = ONE + RETURN + END IF +C + DO 10 I = 1, 2*N+1 + IWORK(I) = 0 + 10 CONTINUE +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance.) +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C Complex workspace: need (N+P)*(N+M). +C + CALL ZLACPY( 'Full', N, M, B, LDB, ZWORK, NP ) + CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(N+1), NP ) + CALL ZLACPY( 'Full', N, N, A, LDA, ZWORK(NP*M+1), NP ) + CALL ZLACPY( 'Full', P, N, C, LDC, ZWORK(NP*M+N+1), NP ) +C +C If required, balance the compound matrix (default MAXRED). +C Real Workspace: need N. +C + KW = WRKOPT + 1 + IF ( LEQUIL ) THEN + MAXRED = ZERO + CALL TB01IZ( 'A', N, M, P, MAXRED, ZWORK(NP*M+1), NP, ZWORK, + $ NP, ZWORK(NP*M+N+1), NP, DWORK, INFO ) + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( NP*NM ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = ZLANGE( 'Frobenius', NP, NM, ZWORK, NP, DWORK ) +C +C Reduce this system to one with the same invariant zeros and with +C D full row rank MU (the normal rank of the original system). +C Real workspace: need 2*MAX(M,P); +C Complex workspace: need (N+P)*(N+M) + +C MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C Integer workspace: 2*N+MAX(M,P)+1. +C + RO = P + SIGMA = 0 + NINFZ = 0 + CALL AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ZWORK, NP, NINFZ, IWORK, + $ IWORK(N+1), MU, NU, NKROL, TOLER, IWORK(2*N+2), + $ DWORK, ZWORK(KW), LZWORK-KW+1, INFO ) + RANK = MU +C + ZWORK(1) = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + RETURN +C *** Last line of AB08MZ *** + END diff --git a/mex/sources/libslicot/AB08ND.f b/mex/sources/libslicot/AB08ND.f new file mode 100644 index 000000000..8fdb139d2 --- /dev/null +++ b/mex/sources/libslicot/AB08ND.f @@ -0,0 +1,568 @@ + SUBROUTINE AB08ND( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, + $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct for a linear multivariable system described by a +C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which +C f f +C has the invariant zeros of the system as generalized eigenvalues. +C The routine also computes the orders of the infinite zeros and the +C right and left Kronecker indices of the system (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NU (output) INTEGER +C The number of (finite) invariant zeros. +C +C RANK (output) INTEGER +C The normal rank of the transfer function matrix. +C +C DINFZ (output) INTEGER +C The maximum degree of infinite elementary divisors. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors +C of degree i, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C AF (output) DOUBLE PRECISION array, dimension +C (LDAF,N+MIN(P,M)) +C The leading NU-by-NU part of this array contains the +C coefficient matrix A of the reduced pencil. The remainder +C f +C of the leading (N+M)-by-(N+MIN(P,M)) part is used as +C internal workspace. +C +C LDAF INTEGER +C The leading dimension of array AF. LDAF >= MAX(1,N+M). +C +C BF (output) DOUBLE PRECISION array, dimension (LDBF,N+M) +C The leading NU-by-NU part of this array contains the +C coefficient matrix B of the reduced pencil. The +C f +C remainder of the leading (N+P)-by-(N+M) part is used as +C internal workspace. +C +C LDBF INTEGER +C The leading dimension of array BF. LDBF >= MAX(1,N+P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M), +C MIN(M,N) + MAX(3*M-1,N+M) ). +C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with +C s = MAX(M,P). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a state-space +C system (A,B,C,D) a regular pencil A - lambda*B which has the +C f f +C invariant zeros of the system as generalized eigenvalues as +C follows: +C +C (a) construct the (N+P)-by-(N+M) compound matrix (B A); +C (D C) +C +C (b) reduce the above system to one with the same invariant +C zeros and with D of full row rank; +C +C (c) pertranspose the system; +C +C (d) reduce the system to one with the same invariant zeros and +C with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C (A - lambda*I B) in order to reduce it to +C ( C D) +C +C (A - lambda*B X) +C ( f f ), with Y and B square invertible; +C ( 0 Y) f +C +C (f) compute the right and left Kronecker indices of the system +C (A,B,C,D), which together with the orders of the infinite +C zeros (determined by steps (a) - (e)) constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C FURTHER COMMENTS +C +C In order to compute the invariant zeros of the system explicitly, +C a call to this routine may be followed by a call to the LAPACK +C Library routine DGGEV with A = A , B = B and N = NU. +C f f +C If RANK = 0, the routine DGEEV can be used (since B = I). +C f +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB08BD by F. Svaricek. +C +C REVISIONS +C +C Oct. 1997, Feb. 1998, Dec. 2003, March 2004, Jan. 2009, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, + $ LDWORK, M, N, NKROL, NKROR, NU, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) + DOUBLE PRECISION A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), + $ C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, + $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL AB08NX, DCOPY, DLACPY, DLASET, DORMRZ, DTZRZF, + $ TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN + INFO = -22 + ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN + INFO = -24 + ELSE + II = MIN( P, M ) + I = MAX( II + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), + $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) + IF( LQUERY ) THEN + SVLMAX = ZERO + NINFZ = 0 + CALL AB08NX( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, -1, + $ INFO ) + WRKOPT = MAX( I, INT( DWORK(1) ) ) + CALL AB08NX( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, + $ -1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + NB = ILAENV( 1, 'DGERQF', ' ', II, N+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', N, N+II, II, -1 ) ) + WRKOPT = MAX( WRKOPT, II + N*NB ) + ELSE IF( LDWORK.LT.I ) THEN + INFO = -28 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08ND', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C + DINFZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( MIN( M, P ).EQ.0 ) THEN + NU = 0 + RANK = 0 + DWORK(1) = ONE + RETURN + END IF + END IF +C + MM = M + NN = N + PP = P +C + DO 20 I = 1, N + INFZ(I) = 0 + 20 CONTINUE +C + IF ( M.GT.0 ) THEN + DO 40 I = 1, N + 1 + KRONR(I) = 0 + 40 CONTINUE + END IF +C + IF ( P.GT.0 ) THEN + DO 60 I = 1, N + 1 + KRONL(I) = 0 + 60 CONTINUE + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + WRKOPT = 1 +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C + CALL DLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) + IF ( PP.GT.0 ) + $ CALL DLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) + IF ( NN.GT.0 ) THEN + CALL DLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) + IF ( PP.GT.0 ) + $ CALL DLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) + END IF +C +C If required, balance the compound matrix (default MAXRED). +C Workspace: need N. +C + IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, + $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) + WRKOPT = N + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) +C +C Reduce this system to one with the same invariant zeros and with +C D upper triangular of full row rank MU (the normal rank of the +C original system). +C Workspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C + RO = PP + SIGMA = 0 + NINFZ = 0 + CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, LDWORK, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + RANK = MU +C +C Pertranspose the system. +C + NUMU = NU + MU + IF ( NUMU.NE.0 ) THEN + MNU = MM + NU + NUMU1 = NUMU + 1 +C + DO 80 I = 1, NUMU + CALL DCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) + 80 CONTINUE +C + IF ( MU.NE.MM ) THEN +C +C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). +C + PP = MM + NN = NU + MM = MU +C +C Reduce the system to one with the same invariant zeros and +C with D square invertible. +C Workspace: need MAX( 1, MU + MAX(3*MU-1,N), +C MIN(M,N) + MAX(3*M-1,N+M) ); +C prefer larger. Note that MU <= MIN(P,M). +C + RO = PP - MM + SIGMA = MM + CALL AB08NX( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C + IF ( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( B A-lambda*I ) +C ( D C ) +C in order to reduce it to +C ( X AF-lambda*BF ) +C ( Y 0 ) +C with Y and BF square invertible. +C + CALL DLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) + CALL DLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) +C + IF ( RANK.NE.0 ) THEN + NU1 = NU + 1 + I1 = NU + MU +C +C Workspace: need 2*MIN(M,P); +C prefer MIN(M,P) + MIN(M,P)*NB. +C + CALL DTZRZF( MU, I1, AF(NU1,1), LDAF, DWORK, DWORK(MU+1), + $ LDWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) +C +C Workspace: need MIN(M,P) + N; +C prefer MIN(M,P) + N*NB. +C + CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, + $ AF(NU1,1), LDAF, DWORK, AF, LDAF, + $ DWORK(MU+1), LDWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(MU+1) ) + MU ) +C + CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU, + $ AF(NU1,1), LDAF, DWORK, BF, LDBF, + $ DWORK(MU+1), LDWORK-MU, INFO ) +C + END IF +C +C Move AF and BF in the first columns. This assumes that +C DLACPY moves column by column. +C + CALL DLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) + IF ( RANK.NE.0 ) + $ CALL DLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) +C + END IF + END IF +C +C Set right Kronecker indices (column indices). +C + IF ( NKROR.GT.0 ) THEN + J = 1 +C + DO 120 I = 1, N + 1 +C + DO 100 II = J, J + KRONR(I) - 1 + IWORK(II) = I - 1 + 100 CONTINUE +C + J = J + KRONR(I) + KRONR(I) = 0 + 120 CONTINUE +C + NKROR = J - 1 +C + DO 140 I = 1, NKROR + KRONR(I) = IWORK(I) + 140 CONTINUE +C + END IF +C +C Set left Kronecker indices (row indices). +C + IF ( NKROL.GT.0 ) THEN + J = 1 +C + DO 180 I = 1, N + 1 +C + DO 160 II = J, J + KRONL(I) - 1 + IWORK(II) = I - 1 + 160 CONTINUE +C + J = J + KRONL(I) + KRONL(I) = 0 + 180 CONTINUE +C + NKROL = J - 1 +C + DO 200 I = 1, NKROL + KRONL(I) = IWORK(I) + 200 CONTINUE +C + END IF +C + IF ( N.GT.0 ) THEN + DINFZ = N +C + 220 CONTINUE + IF ( INFZ(DINFZ).EQ.0 ) THEN + DINFZ = DINFZ - 1 + IF ( DINFZ.GT.0 ) + $ GO TO 220 + END IF + END IF +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB08ND *** + END diff --git a/mex/sources/libslicot/AB08NX.f b/mex/sources/libslicot/AB08NX.f new file mode 100644 index 000000000..d67f6a193 --- /dev/null +++ b/mex/sources/libslicot/AB08NX.f @@ -0,0 +1,446 @@ + SUBROUTINE AB08NX( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, + $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) system +C ( B A ) +C ( D C ) +C an (NU+MU)-by-(M+NU) "reduced" system +C ( B' A') +C ( D' C') +C having the same transmission zeros but with D' of full row rank. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C RO (input/output) INTEGER +C On entry, +C = P for the original system; +C = MAX(P-M, 0) for the pertransposed system. +C On exit, RO contains the last computed rank. +C +C SIGMA (input/output) INTEGER +C On entry, +C = 0 for the original system; +C = M for the pertransposed system. +C On exit, SIGMA contains the last computed value sigma in +C the algorithm. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) DOUBLE PRECISION array, dimension +C (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound input matrix of the system. +C On exit, the leading (NU+MU)-by-(M+NU) part of this array +C contains the reduced compound input matrix of the system. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C NINFZ (input/output) INTEGER +C On entry, the currently computed number of infinite zeros. +C It should be initialized to zero on the first call. +C NINFZ >= 0. +C On exit, the number of infinite zeros. +C +C INFZ (input/output) INTEGER array, dimension (N) +C On entry, INFZ(i) must contain the current number of +C infinite zeros of degree i, where i = 1,2,...,N, found in +C the previous call(s) of the routine. It should be +C initialized to zero on the first call. +C On exit, INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,N. +C +C KRONL (input/output) INTEGER array, dimension (N+1) +C On entry, this array must contain the currently computed +C left Kronecker (row) indices found in the previous call(s) +C of the routine. It should be initialized to zero on the +C first call. +C On exit, the leading NKROL elements of this array contain +C the left Kronecker (row) indices. +C +C MU (output) INTEGER +C The normal rank of the transfer function matrix of the +C original system. +C +C NU (output) INTEGER +C The dimension of the reduced system matrix and the number +C of (finite) invariant zeros if D' is invertible. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Supersedes Release 2.0 routine AB08BZ by F. Svaricek. +C +C REVISIONS +C +C V. Sima, Oct. 1997; Feb. 1998, Jan. 2009, Apr. 2009. +C A. Varga, May 1999; May 2001. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDABCD, LDWORK, M, MU, N, NINFZ, NKROL, + $ NU, P, RO, SIGMA + DOUBLE PRECISION SVLMAX, TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*) + DOUBLE PRECISION ABCD(LDABCD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, + $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT + DOUBLE PRECISION T +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DLAPMT, DLARFG, DLASET, DLATZM, DORMQR, DORMRQ, + $ MB03OY, MB03PY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + NP = N + P + MPM = MIN( P, M ) + INFO = 0 + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN + INFO = -4 + ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN + INFO = -8 + ELSE IF( NINFZ.LT.0 ) THEN + INFO = -9 + ELSE + JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) + IF( LQUERY ) THEN + IF( M.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, MPM, + $ -1 ) ) + WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) + ELSE + WRKOPT = JWORK + END IF + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', NP, N, MIN( P, N ), + $ -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'LN', N, M+N, + $ MIN( P, N ), -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) + ELSE IF( LDWORK.LT.JWORK ) THEN + INFO = -18 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08NX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C + MU = P + NU = N +C + IZ = 0 + IK = 1 + MM1 = M + 1 + ITAU = 1 + NKROL = 0 + WRKOPT = 1 +C +C Main reduction loop: +C +C M NU M NU +C NU [ B A ] NU [ B A ] +C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = +C TAU [ 0 C2 ] row size of RD) +C +C M NU-RO RO +C NU-RO [ B1 A11 A12 ] +C --> RO [ B2 A21 A22 ] (RO = rank(C2) = +C SIGMA [ RD C11 C12 ] col size of LC) +C TAU [ 0 0 LC ] +C +C M NU-RO +C NU-RO [ B1 A11 ] NU := NU - RO +C [----------] MU := RO + SIGMA +C --> RO [ B2 A21 ] D := [B2;RD] +C SIGMA [ RD C11 ] C := [A21;C11] +C + 20 IF ( MU.EQ.0 ) + $ GO TO 80 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + RO1 = RO + MNU = M + NU + IF ( M.GT.0 ) THEN + IF ( SIGMA.NE.0 ) THEN + IROW = NU + 1 +C +C Compress rows of D. First exploit triangular shape. +C Workspace: need M+N-1. +C + DO 40 I1 = 1, SIGMA + CALL DLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, T ) + CALL DLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, T, + $ ABCD(IROW,I1+1), ABCD(IROW+1,I1+1), LDABCD, + $ DWORK ) + IROW = IROW + 1 + 40 CONTINUE + CALL DLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, + $ ABCD(NU+2,1), LDABCD ) + END IF +C +C Continue with Householder with column pivoting. +C +C The rank of D is the number of (estimated) singular values +C that are greater than TOL * MAX(SVLMAX,EMSV). This number +C includes the singular values of the first SIGMA columns. +C Integer workspace: need M; +C Workspace: need min(RO1,M) + 3*M - 1. RO1 <= P. +C + IF ( SIGMA.LT.M ) THEN + JWORK = ITAU + MIN( RO1, M ) + I1 = SIGMA + 1 + IROW = NU + I1 + CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, + $ SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), + $ DWORK(JWORK), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) +C +C Apply the column permutations to matrices B and part of D. +C + CALL DLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, + $ IWORK ) +C + IF ( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C Workspace: need min(RO1,M) + NU; +C prefer min(RO1,M) + NU*NB. +C + CALL DORMQR( 'Left', 'Transpose', RO1, NU, RANK, + $ ABCD(IROW,I1), LDABCD, DWORK(ITAU), + $ ABCD(IROW,MM1), LDABCD, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( RO1.GT.1 ) + $ CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, + $ ZERO, ABCD(IROW+1,I1), LDABCD ) + RO1 = RO1 - RANK + END IF + END IF + END IF +C + TAU = RO1 + SIGMA = MU - TAU +C +C Determination of the orders of the infinite zeros. +C + IF ( IZ.GT.0 ) THEN + INFZ(IZ) = INFZ(IZ) + RO - TAU + NINFZ = NINFZ + IZ*( RO - TAU ) + END IF + IF ( RO1.EQ.0 ) + $ GO TO 80 + IZ = IZ + 1 +C + IF ( NU.LE.0 ) THEN + MU = SIGMA + NU = 0 + RO = 0 + ELSE +C +C Compress the columns of C2 using RQ factorization with row +C pivoting, P * C2 = R * Q. +C + I1 = NU + SIGMA + 1 + MNTAU = MIN( TAU, NU ) + JWORK = ITAU + MNTAU +C +C The rank of C2 is the number of (estimated) singular values +C greater than TOL * MAX(SVLMAX,EMSV). +C Integer Workspace: need TAU; +C Workspace: need min(TAU,NU) + 3*TAU - 1. +C + CALL MB03PY( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, + $ SVAL, IWORK, DWORK(ITAU), DWORK(JWORK), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) + IF ( RANK.GT.0 ) THEN + IROW = I1 + TAU - RANK +C +C Apply Q' to the first NU columns of [A; C1] from the right. +C Workspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; +C prefer min(TAU,NU) + (NU + SIGMA)*NB. +C + CALL DORMRQ( 'Right', 'Transpose', I1-1, NU, RANK, + $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), + $ ABCD(1,MM1), LDABCD, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Apply Q to the first NU rows and M + NU columns of [ B A ] +C from the left. +C Workspace: need min(TAU,NU) + M + NU; +C prefer min(TAU,NU) + (M + NU)*NB. +C + CALL DORMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, + $ ABCD(IROW,MM1), LDABCD, DWORK(MNTAU-RANK+1), + $ ABCD, LDABCD, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + CALL DLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, + $ ABCD(IROW,MM1), LDABCD ) + IF ( RANK.GT.1 ) + $ CALL DLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, + $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) + END IF +C + RO = RANK + END IF +C +C Determine the left Kronecker indices (row indices). +C + KRONL(IK) = KRONL(IK) + TAU - RO + NKROL = NKROL + KRONL(IK) + IK = IK + 1 +C +C C and D are updated to [A21 ; C11] and [B2 ; RD]. +C + NU = NU - RO + MU = SIGMA + RO + IF ( RO.NE.0 ) + $ GO TO 20 +C + 80 CONTINUE + DWORK(1) = WRKOPT + RETURN +C *** Last line of AB08NX *** + END diff --git a/mex/sources/libslicot/AB08NZ.f b/mex/sources/libslicot/AB08NZ.f new file mode 100644 index 000000000..9638b4bbb --- /dev/null +++ b/mex/sources/libslicot/AB08NZ.f @@ -0,0 +1,576 @@ + SUBROUTINE AB08NZ( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NU, RANK, DINFZ, NKROR, NKROL, INFZ, KRONR, + $ KRONL, AF, LDAF, BF, LDBF, TOL, IWORK, DWORK, + $ ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct for a linear multivariable system described by a +C state-space model (A,B,C,D) a regular pencil (A - lambda*B ) which +C f f +C has the invariant zeros of the system as generalized eigenvalues. +C The routine also computes the orders of the infinite zeros and the +C right and left Kronecker indices of the system (A,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the compound +C matrix (see METHOD) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables, i.e., the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) COMPLEX*16 array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) COMPLEX*16 array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) COMPLEX*16 array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) COMPLEX*16 array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NU (output) INTEGER +C The number of (finite) invariant zeros. +C +C RANK (output) INTEGER +C The normal rank of the transfer function matrix. +C +C DINFZ (output) INTEGER +C The maximum degree of infinite elementary divisors. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors +C of degree i, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (MAX(N,M)+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C KRONL (output) INTEGER array, dimension (MAX(N,P)+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C AF (output) COMPLEX*16 array, dimension (LDAF,N+MIN(P,M)) +C The leading NU-by-NU part of this array contains the +C coefficient matrix A of the reduced pencil. The remainder +C f +C of the leading (N+M)-by-(N+MIN(P,M)) part is used as +C internal workspace. +C +C LDAF INTEGER +C The leading dimension of array AF. LDAF >= MAX(1,N+M). +C +C BF (output) COMPLEX*16 array, dimension (LDBF,N+M) +C The leading NU-by-NU part of this array contains the +C coefficient matrix B of the reduced pencil. The +C f +C remainder of the leading (N+P)-by-(N+M) part is used as +C internal workspace. +C +C LDBF INTEGER +C The leading dimension of array BF. LDBF >= MAX(1,N+P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL to be less than SQRT((N+P)*(N+M))*EPS +C then the tolerance is taken as SQRT((N+P)*(N+M))*EPS, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N,2*MAX(P,M))) +C +C ZWORK DOUBLE PRECISION array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M), +C MIN(M,N) + MAX(3*M-1,N+M) ). +C An upper bound is MAX(s,N) + MAX(3*s-1,N+s), with +C s = MAX(M,P). +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a state-space +C system (A,B,C,D) a regular pencil A - lambda*B which has the +C f f +C invariant zeros of the system as generalized eigenvalues as +C follows: +C +C (a) construct the (N+P)-by-(N+M) compound matrix (B A); +C (D C) +C +C (b) reduce the above system to one with the same invariant +C zeros and with D of full row rank; +C +C (c) pertranspose the system; +C +C (d) reduce the system to one with the same invariant zeros and +C with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C (A - lambda*I B) in order to reduce it to +C ( C D) +C +C (A - lambda*B X) +C ( f f ), with Y and B square invertible; +C ( 0 Y) f +C +C (f) compute the right and left Kronecker indices of the system +C (A,B,C,D), which together with the orders of the infinite +C zeros (determined by steps (a) - (e)) constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [2] and [1]). +C +C FURTHER COMMENTS +C +C In order to compute the invariant zeros of the system explicitly, +C a call to this routine may be followed by a call to the LAPACK +C Library routine ZGGEV with A = A , B = B and N = NU. +C f f +C If RANK = 0, the routine ZGEEV can be used (since B = I). +C f +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, unitary transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION DZERO + PARAMETER ( DZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, LDA, LDAF, LDB, LDBF, LDC, LDD, + $ LZWORK, M, N, NKROL, NKROR, NU, P, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*), KRONR(*) + COMPLEX*16 A(LDA,*), AF(LDAF,*), B(LDB,*), BF(LDBF,*), + $ C(LDC,*), D(LDD,*), ZWORK(*) + DOUBLE PRECISION DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I1, II, J, MM, MNU, MU, NB, NINFZ, NN, NU1, + $ NUMU, NUMU1, PP, RO, SIGMA, WRKOPT + DOUBLE PRECISION MAXRED, SVLMAX, THRESH, TOLER +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL AB8NXZ, TB01IZ, XERBLA, ZCOPY, ZLACPY, ZLASET, + $ ZTZRZF, ZUNMRZ +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LZWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDAF.LT.MAX( 1, N + M ) ) THEN + INFO = -22 + ELSE IF( LDBF.LT.MAX( 1, N + P ) ) THEN + INFO = -24 + ELSE + II = MIN( P, M ) + I = MAX( II + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, N+P, N+M ), + $ MIN( M, N ) + MAX( 3*M - 1, N+M ), 1 ) + IF( LQUERY ) THEN + SVLMAX = DZERO + NINFZ = 0 + CALL AB8NXZ( N, M, P, P, 0, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, + $ ZWORK, -1, INFO ) + WRKOPT = MAX( I, INT( ZWORK(1) ) ) + CALL AB8NXZ( N, II, M, M-II, II, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, DWORK, + $ ZWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) + NB = ILAENV( 1, 'ZGERQF', ' ', II, N+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', N, N+II, II, -1 ) ) + WRKOPT = MAX( WRKOPT, II + N*NB ) + ELSE IF( LZWORK.LT.I ) THEN + INFO = -29 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB08NZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C + DINFZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( MIN( M, P ).EQ.0 ) THEN + NU = 0 + RANK = 0 + ZWORK(1) = ONE + RETURN + END IF + END IF +C + MM = M + NN = N + PP = P +C + DO 20 I = 1, N + INFZ(I) = 0 + 20 CONTINUE +C + IF ( M.GT.0 ) THEN + DO 40 I = 1, N + 1 + KRONR(I) = 0 + 40 CONTINUE + END IF +C + IF ( P.GT.0 ) THEN + DO 60 I = 1, N + 1 + KRONL(I) = 0 + 60 CONTINUE + END IF +C +C (Note: Comments in the code beginning "CWorkspace:" and +C "RWorkspace:" describe the minimal amount of complex and real +C workspace, respectively, needed at that point in the code, as +C well as the preferred amount for good performance.) +C + WRKOPT = 1 +C +C Construct the compound matrix ( B A ), dimension (N+P)-by-(M+N). +C ( D C ) +C + CALL ZLACPY( 'Full', NN, MM, B, LDB, BF, LDBF ) + IF ( PP.GT.0 ) + $ CALL ZLACPY( 'Full', PP, MM, D, LDD, BF(1+NN,1), LDBF ) + IF ( NN.GT.0 ) THEN + CALL ZLACPY( 'Full', NN, NN, A, LDA, BF(1,1+MM), LDBF ) + IF ( PP.GT.0 ) + $ CALL ZLACPY( 'Full', PP, NN, C, LDC, BF(1+NN,1+MM), LDBF ) + END IF +C +C If required, balance the compound matrix (default MAXRED). +C RWorkspace: need N. +C + IF ( LEQUIL .AND. NN.GT.0 .AND. PP.GT.0 ) THEN + MAXRED = DZERO + CALL TB01IZ( 'A', NN, MM, PP, MAXRED, BF(1,1+MM), LDBF, BF, + $ LDBF, BF(1+NN,1+MM), LDBF, DWORK, INFO ) + END IF +C +C If required, set tolerance. +C + THRESH = SQRT( DBLE( (N + P)*(N + M) ) )*DLAMCH( 'Precision' ) + TOLER = TOL + IF ( TOLER.LT.THRESH ) TOLER = THRESH + SVLMAX = ZLANGE( 'Frobenius', NN+PP, NN+MM, BF, LDBF, DWORK ) +C +C Reduce this system to one with the same invariant zeros and with +C D upper triangular of full row rank MU (the normal rank of the +C original system). +C RWorkspace: need 2*MAX(M,P); +C CWorkspace: need MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ); +C prefer larger. +C + RO = PP + SIGMA = 0 + NINFZ = 0 + CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, BF, LDBF, NINFZ, INFZ, + $ KRONL, MU, NU, NKROL, TOLER, IWORK, DWORK, ZWORK, + $ LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) + RANK = MU +C +C Pertranspose the system. +C + NUMU = NU + MU + IF ( NUMU.NE.0 ) THEN + MNU = MM + NU + NUMU1 = NUMU + 1 +C + DO 80 I = 1, NUMU + CALL ZCOPY( MNU, BF(I,1), LDBF, AF(1,NUMU1-I), -1 ) + 80 CONTINUE +C + IF ( MU.NE.MM ) THEN +C +C Here MU < MM and MM > 0 (since MM = 0 implies MU = 0 = MM). +C + PP = MM + NN = NU + MM = MU +C +C Reduce the system to one with the same invariant zeros and +C with D square invertible. +C RWorkspace: need 2*M. +C CWorkspace: need MAX( 1, MU + MAX(3*MU-1,N), +C MIN(M,N) + MAX(3*M-1,N+M) ); +C prefer larger. Note that MU <= MIN(M,P). +C + RO = PP - MM + SIGMA = MM + CALL AB8NXZ( NN, MM, PP, RO, SIGMA, SVLMAX, AF, LDAF, NINFZ, + $ INFZ, KRONR, MU, NU, NKROR, TOLER, IWORK, + $ DWORK, ZWORK, LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) + END IF +C + IF ( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( B A-lambda*I ) +C ( D C ) +C in order to reduce it to +C ( X AF-lambda*BF ) +C ( Y 0 ) +C with Y and BF square invertible. +C + CALL ZLASET( 'Full', NU, MU, ZERO, ZERO, BF, LDBF ) + CALL ZLASET( 'Full', NU, NU, ZERO, ONE, BF(1,MU+1), LDBF ) +C + IF ( RANK.NE.0 ) THEN + NU1 = NU + 1 + I1 = NU + MU +C +C CWorkspace: need 2*MIN(M,P); +C prefer MIN(M,P) + MIN(M,P)*NB. +C + CALL ZTZRZF( MU, I1, AF(NU1,1), LDAF, ZWORK, ZWORK(MU+1), + $ LZWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) +C +C CWorkspace: need MIN(M,P) + N; +C prefer MIN(M,P) + N*NB. +C + CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, + $ NU, AF(NU1,1), LDAF, ZWORK, AF, LDAF, + $ ZWORK(MU+1), LZWORK-MU, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(MU+1) ) + MU ) +C + CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, I1, MU, + $ NU, AF(NU1,1), LDAF, ZWORK, BF, LDBF, + $ ZWORK(MU+1), LZWORK-MU, INFO ) +C + END IF +C +C Move AF and BF in the first columns. This assumes that +C ZLACPY moves column by column. +C + CALL ZLACPY( 'Full', NU, NU, AF(1,MU+1), LDAF, AF, LDAF ) + IF ( RANK.NE.0 ) + $ CALL ZLACPY( 'Full', NU, NU, BF(1,MU+1), LDBF, BF, LDBF ) +C + END IF + END IF +C +C Set right Kronecker indices (column indices). +C + IF ( NKROR.GT.0 ) THEN + J = 1 +C + DO 120 I = 1, N + 1 +C + DO 100 II = J, J + KRONR(I) - 1 + IWORK(II) = I - 1 + 100 CONTINUE +C + J = J + KRONR(I) + KRONR(I) = 0 + 120 CONTINUE +C + NKROR = J - 1 +C + DO 140 I = 1, NKROR + KRONR(I) = IWORK(I) + 140 CONTINUE +C + END IF +C +C Set left Kronecker indices (row indices). +C + IF ( NKROL.GT.0 ) THEN + J = 1 +C + DO 180 I = 1, N + 1 +C + DO 160 II = J, J + KRONL(I) - 1 + IWORK(II) = I - 1 + 160 CONTINUE +C + J = J + KRONL(I) + KRONL(I) = 0 + 180 CONTINUE +C + NKROL = J - 1 +C + DO 200 I = 1, NKROL + KRONL(I) = IWORK(I) + 200 CONTINUE +C + END IF +C + IF ( N.GT.0 ) THEN + DINFZ = N +C + 220 CONTINUE + IF ( INFZ(DINFZ).EQ.0 ) THEN + DINFZ = DINFZ - 1 + IF ( DINFZ.GT.0 ) + $ GO TO 220 + END IF + END IF +C + ZWORK(1) = WRKOPT + RETURN +C *** Last line of AB08NZ *** + END diff --git a/mex/sources/libslicot/AB09AD.f b/mex/sources/libslicot/AB09AD.f new file mode 100644 index 000000000..8d04fa633 --- /dev/null +++ b/mex/sources/libslicot/AB09AD.f @@ -0,0 +1,363 @@ + SUBROUTINE AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, + $ B, LDB, C, LDC, HSV, TOL, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr) for a stable original +C state-space representation (A,B,C) by using either the square-root +C or the balancing-free square-root Balance & Truncate (B & T) +C model reduction method. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If ORDSEL = 'A', TOL contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL <= 0 on entry. +C If ORDSEL = 'F', the value of TOL is ignored. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOB = 'B'; +C LIWORK = N, if JOB = 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to the real Schur form failed; +C = 2: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 3: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09AD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the square-root Balance & Truncate method of [1] +C is used and, for DICO = 'C', the resulting model is balanced. +C By setting TOL <= 0, the routine can be used to compute balanced +C minimal state-space realizations of stable systems. +C +C If JOB = 'N', the balancing-free square-root version of the +C Balance & Truncate method [2] is used. +C By setting TOL <= 0, the routine can be used to compute minimal +C state-space realizations of stable systems. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), +C Vol. 2, pp. 42-46. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routines SRBT and SRBFT. +C +C REVISIONS +C +C May 2, 1998. +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C +C KEYWORDS +C +C Balancing, minimal state-space representation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, C100 + PARAMETER ( ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL FIXORD + INTEGER IERR, KI, KR, KT, KTI, KW, NN + DOUBLE PRECISION MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09AX, TB01ID, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -19 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Allocate working storage. +C + NN = N*N + KT = 1 + KR = KT + NN + KI = KR + N + KW = KI + N +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Reduce A to the real Schur form using an orthogonal similarity +C transformation A <- T'*A*T and apply the transformation to +C B and C: B <- T'*B and C <- C*T. +C + CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, + $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) + KTI = KT + NN + KW = KTI + NN +C + CALL AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, + $ LDC, HSV, DWORK(KT), N, DWORK(KTI), N, TOL, IWORK, + $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C + RETURN +C *** Last line of AB09AD *** + END diff --git a/mex/sources/libslicot/AB09AX.f b/mex/sources/libslicot/AB09AX.f new file mode 100644 index 000000000..6d333337a --- /dev/null +++ b/mex/sources/libslicot/AB09AX.f @@ -0,0 +1,564 @@ + SUBROUTINE AB09AX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, HSV, T, LDT, TI, LDTI, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr) for a stable original +C state-space representation (A,B,C) by using either the square-root +C or the balancing-free square-root Balance & Truncate model +C reduction method. The state dynamics matrix A of the original +C system is an upper quasi-triangular matrix in real Schur canonical +C form. The matrices of the reduced order system are computed using +C the truncation formulas: +C +C Ar = TI * A * T , Br = TI * B , Cr = C * T . +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A in a real Schur +C canonical form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,N) +C If INFO = 0 and NR > 0, the leading N-by-NR part of this +C array contains the right truncation matrix T. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) +C If INFO = 0 and NR > 0, the leading NR-by-N part of this +C array contains the left truncation matrix TI. +C +C LDTI INTEGER +C The leading dimension of array TI. LDTI >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If ORDSEL = 'A', TOL contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL <= 0 on entry. +C If ORDSEL = 'F', the value of TOL is ignored. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOB = 'B', or +C LIWORK = N, if JOB = 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 2: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09AX determines for +C the given system (1), the matrices of a reduced NR order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the square-root Balance & Truncate method of [1] +C is used and, for DICO = 'C', the resulting model is balanced. +C By setting TOL <= 0, the routine can be used to compute balanced +C minimal state-space realizations of stable systems. +C +C If JOB = 'N', the balancing-free square-root version of the +C Balance & Truncate method [2] is used. +C By setting TOL <= 0, the routine can be used to compute minimal +C state-space realizations of stable systems. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), +C Vol. 2, pp. 42-46. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routines SRBT1 and SRBFT1. +C +C REVISIONS +C +C May 2, 1998. +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C February 14, 1999, A. Varga, German Aerospace Center. +C February 22, 1999, V. Sima, Research Institute for Informatics. +C February 27, 2000, V. Sima, Research Institute for Informatics. +C +C KEYWORDS +C +C Balancing, minimal state-space representation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDT, LDTI, LDWORK, + $ M, N, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*), + $ T(LDT,*), TI(LDTI,*) +C .. Local Scalars .. + LOGICAL BAL, DISCR, FIXORD, PACKED + INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, WRKOPT + DOUBLE PRECISION ATOL, RTOL, SCALEC, SCALEO, TEMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, DLACPY, + $ DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, MA02AD, + $ MA02DD, MB03UD, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BAL = LSAME( JOB, 'B' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -22 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09AX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C + RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) +C +C Allocate N*MAX(N,M,P) and N working storage for the matrices U +C and TAU, respectively. +C + KU = 1 + KTAU = KU + N*MAX( N, M, P ) + KW = KTAU + N + LDW = LDWORK - KW + 1 +C +C Copy B in U. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) +C +C If DISCR = .FALSE., solve for Su the Lyapunov equation +C 2 +C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . +C +C If DISCR = .TRUE., solve for Su the Lyapunov equation +C 2 +C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . +C +C Workspace: need N*(MAX(N,M,P) + 5); +C prefer larger. +C + CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Copy C in U. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) +C +C If DISCR = .FALSE., solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . +C +C If DISCR = .TRUE., solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . +C +C Workspace: need N*(MAX(N,M,P) + 5); +C prefer larger. +C + CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, + $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the +C matrix V, a packed (or unpacked) copy of Su, and save Su in V. +C (The locations for TAU are reused here.) +C + KV = KTAU + IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN + PACKED = .TRUE. + CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) + KW = KV + ( N*( N + 1 ) )/2 + ELSE + PACKED = .FALSE. + CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) + KW = KV + N*N + END IF +C | x x | +C Compute Ru*Su in the form | 0 x | in TI. +C + DO 10 J = 1, N + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, + $ TI(1,J), 1 ) + 10 CONTINUE +C +C Compute the singular value decomposition Ru*Su = V*S*UT +C of the upper triangular matrix Ru*Su, with UT in TI and V in U. +C +C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + ENDIF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Scale singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) +C +C Partition S, U and V conformally as: +C +C S = diag(S1,S2), U = [U1,U2] (U' in TI) and V = [V1,V2] (in U). +C +C Compute the order of reduced system, as the order of S1. +C + ATOL = RTOL*HSV(1) + IF( FIXORD ) THEN + IF( NR.GT.0 ) THEN + IF( HSV(NR).LE.ATOL ) THEN + NR = 0 + IWARN = 1 + FIXORD = .FALSE. + ENDIF + ENDIF + ELSE + ATOL = MAX( TOL, ATOL ) + NR = 0 + ENDIF + IF( .NOT.FIXORD ) THEN + DO 20 J = 1, N + IF( HSV(J).LE.ATOL ) GO TO 30 + NR = NR + 1 + 20 CONTINUE + 30 CONTINUE + ENDIF +C + IF( NR.EQ.0 ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute the truncation matrices. +C +C Compute TI' = Ru'*V1 in U. +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NR, ONE, + $ T, LDT, DWORK(KU), N ) +C +C Compute T = Su*U1 (with Su packed, if not enough workspace). +C + CALL MA02AD( 'Full', NR, N, TI, LDTI, T, LDT ) + IF ( PACKED ) THEN + DO 40 J = 1, NR + CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), + $ T(1,J), 1 ) + 40 CONTINUE + ELSE + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, NR, + $ ONE, DWORK(KV), N, T, LDT ) + END IF +C + IF( BAL ) THEN + IJ = KU +C +C Square-Root B & T method. +C +C Compute the truncation matrices for balancing +C -1/2 -1/2 +C T*S1 and TI'*S1 +C + DO 50 J = 1, NR + TEMP = ONE/SQRT( HSV(J) ) + CALL DSCAL( N, TEMP, T(1,J), 1 ) + CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) + IJ = IJ + N + 50 CONTINUE + ELSE +C +C Balancing-Free B & T method. +C +C Compute orthogonal bases for the images of matrices T and TI'. +C +C Workspace: need N*MAX(N,M,P) + 2*NR; +C prefer N*MAX(N,M,P) + NR*(NB+1) +C (NB determined by ILAENV for DGEQRF). +C + KW = KTAU + NR + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) + CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C +C Transpose TI' to obtain TI. +C + CALL MA02AD( 'Full', N, NR, DWORK(KU), N, TI, LDTI ) +C + IF( .NOT.BAL ) THEN +C -1 +C Compute (TI*T) *TI in TI. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, + $ LDTI, T, LDT, ZERO, DWORK(KU), N ) + CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, + $ LDTI, IERR ) + END IF +C +C Compute TI*A*T (A is in RSF). +C + IJ = KU + DO 60 J = 1, N + K = MIN( J+1, N ) + CALL DGEMV( 'NoTranspose', NR, K, ONE, TI, LDTI, A(1,J), 1, + $ ZERO, DWORK(IJ), 1 ) + IJ = IJ + N + 60 CONTINUE + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, + $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) +C +C Compute TI*B and C*T. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, N, ONE, TI, LDTI, + $ DWORK(KU), N, ZERO, B, LDB ) +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, N, ONE, + $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09AX *** + END diff --git a/mex/sources/libslicot/AB09BD.f b/mex/sources/libslicot/AB09BD.f new file mode 100644 index 000000000..0aa01b394 --- /dev/null +++ b/mex/sources/libslicot/AB09BD.f @@ -0,0 +1,385 @@ + SUBROUTINE AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, A, LDA, + $ B, LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable +C original state-space representation (A,B,C,D) by using either the +C square-root or the balancing-free square-root Singular +C Perturbation Approximation (SPA) model reduction method. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root SPA method; +C = 'N': use the balancing-free square-root SPA method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL1 <= 0 on entry. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the given system. The recommended value is +C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default +C if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to the real Schur form failed; +C = 2: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 3: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09BD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the balancing-based square-root SPA method of [1] +C is used and the resulting model is balanced. +C +C If JOB = 'N', the balancing-free square-root SPA method of [2] +C is used. +C By setting TOL1 = TOL2, the routine can be used to compute +C Balance & Truncate approximations. +C +C REFERENCES +C +C [1] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of Balanced Systems, +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [2] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRBFSP. +C +C REVISIONS +C +C May 2, 1998. +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C +C KEYWORDS +C +C Balancing, minimal state-space representation, model reduction, +C multivariable system, singular perturbation approximation, +C state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL FIXORD + INTEGER IERR, KI, KR, KT, KTI, KW, NN + DOUBLE PRECISION MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09BX, TB01ID, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -22 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Allocate working storage. +C + NN = N*N + KT = 1 + KR = KT + NN + KI = KR + N + KW = KI + N +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Reduce A to the real Schur form using an orthogonal similarity +C transformation A <- T'*A*T and apply the transformation to +C B and C: B <- T'*B and C <- C*T. +C + CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, + $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + KTI = KT + NN + KW = KTI + NN + CALL AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, HSV, DWORK(KT), N, DWORK(KTI), N, + $ TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, + $ IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C + RETURN +C *** Last line of AB09BD *** + END diff --git a/mex/sources/libslicot/AB09BX.f b/mex/sources/libslicot/AB09BX.f new file mode 100644 index 000000000..438babc5d --- /dev/null +++ b/mex/sources/libslicot/AB09BX.f @@ -0,0 +1,662 @@ + SUBROUTINE AB09BX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable +C original state-space representation (A,B,C,D) by using either the +C square-root or the balancing-free square-root +C Singular Perturbation Approximation (SPA) model reduction method. +C The state dynamics matrix A of the original system is an upper +C quasi-triangular matrix in real Schur canonical form. The matrices +C of a minimal realization are computed using the truncation +C formulas: +C +C Am = TI * A * T , Bm = TI * B , Cm = C * T . (1) +C +C Am, Bm, Cm and D serve further for computing the SPA of the given +C system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root SPA method; +C = 'N': use the balancing-free square-root SPA method. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A in a real Schur +C canonical form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,N) +C If INFO = 0 and NR > 0, the leading N-by-NR part of this +C array contains the right truncation matrix T in (1). +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) +C If INFO = 0 and NR > 0, the leading NR-by-N part of this +C array contains the left truncation matrix TI in (1). +C +C LDTI INTEGER +C The leading dimension of array TI. LDTI >= MAX(1,N). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL1 <= 0 on entry. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the given system. The recommended value is +C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default +C if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(MAX(N,M,P)+5) + N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 2: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (2) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09BX determines for +C the given system (1), the matrices of a reduced NR order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (3) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the balancing-based square-root SPA method of [1] +C is used and the resulting model is balanced. +C +C If JOB = 'N', the balancing-free square-root SPA method of [2] +C is used. +C By setting TOL1 = TOL2, the routine can be also used to compute +C Balance & Truncate approximations. +C +C REFERENCES +C +C [1] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of Balanced Systems, +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [2] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRBFP1. +C +C REVISIONS +C +C May 2, 1998. +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C December 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C February 14, 1999, A. Varga, German Aerospace Center. +C February 22, 1999, V. Sima, Research Institute for Informatics. +C February 27, 2000, V. Sima, Research Institute for Informatics. +C May 26, 2000, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Balancing, minimal state-space representation, model reduction, +C multivariable system, singular perturbation approximation, +C state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, + $ LDWORK, M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) +C .. Local Scalars .. + LOGICAL BAL, DISCR, FIXORD, PACKED + INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, NMINR, + $ NR1, NS, WRKOPT + DOUBLE PRECISION ATOL, RCOND, RTOL, SCALEC, SCALEO, TEMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, + $ DLACPY, DORGQR, DSCAL, DTPMV, DTRMM, DTRMV, + $ MA02AD, MA02DD, MB03UD, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BAL = LSAME( JOB, 'B' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BAL .OR. LSAME( JOB, 'N') ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -22 + ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09BX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) +C +C Allocate N*MAX(N,M,P) and N working storage for the matrices U +C and TAU, respectively. +C + KU = 1 + KTAU = KU + N*MAX( N, M, P ) + KW = KTAU + N + LDW = LDWORK - KW + 1 +C +C Copy B in U. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) +C +C If DISCR = .FALSE., solve for Su the Lyapunov equation +C 2 +C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . +C +C If DISCR = .TRUE., solve for Su the Lyapunov equation +C 2 +C A*(Su*Su')*A' + scalec *B*B' = Su*Su' . +C +C Workspace: need N*(MAX(N,M,P) + 5); +C prefer larger. +C + CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), TI, LDTI, SCALEC, DWORK(KW), LDW, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Copy C in U. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) +C +C If DISCR = .FALSE., solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * C'*C = 0 . +C +C If DISCR = .TRUE., solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru)*A + scaleo * C'*C = Ru'*Ru . +C +C Workspace: need N*(MAX(N,M,P) + 5); +C prefer larger. +C + CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, + $ DWORK(KTAU), T, LDT, SCALEO, DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Allocate N*(N+1)/2 (or, if possible, N*N) working storage for the +C matrix V, a packed (or unpacked) copy of Su, and save Su in V. +C (The locations for TAU are reused here.) +C + KV = KTAU + IF ( LDWORK-KV+1.LT.N*( N + 5 ) ) THEN + PACKED = .TRUE. + CALL MA02DD( 'Pack', 'Upper', N, TI, LDTI, DWORK(KV) ) + KW = KV + ( N*( N + 1 ) )/2 + ELSE + PACKED = .FALSE. + CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) + KW = KV + N*N + END IF +C | x x | +C Compute Ru*Su in the form | 0 x | in TI. +C + DO 10 J = 1, N + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, + $ TI(1,J), 1 ) + 10 CONTINUE +C +C Compute the singular value decomposition Ru*Su = V*S*UT +C of the upper triangular matrix Ru*Su, with UT in TI and V in U. +C +C Workspace: need N*MAX(N,M,P) + N*(N+1)/2 + 5*N; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + ENDIF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Scale singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) +C +C Partition S, U and V conformally as: +C +C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] +C (in U). +C +C Compute the order NR of reduced system, as the order of S1. +C + ATOL = RTOL*HSV(1) + IF( FIXORD ) THEN + IF( NR.GT.0 ) THEN + IF( HSV(NR).LE.ATOL ) THEN + NR = 0 + IWARN = 1 + FIXORD = .FALSE. + ENDIF + ENDIF + ELSE + ATOL = MAX( TOL1, ATOL ) + NR = 0 + ENDIF + IF( .NOT.FIXORD ) THEN + DO 20 J = 1, N + IF( HSV(J).LE.ATOL ) GO TO 30 + NR = NR + 1 + 20 CONTINUE + 30 CONTINUE + ENDIF +C +C Finish if the order of the reduced model is zero. +C + IF( NR.EQ.0 ) THEN +C +C Compute only Dr using singular perturbation formulas. +C Workspace: need real 4*N; +C need integer 2*N. +C + CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, D, + $ LDD, RCOND, IWORK, DWORK, IERR ) + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute the order of minimal realization as the order of [S1 S2]. +C + NR1 = NR + 1 + NMINR = NR + IF( NR.LT.N ) THEN + ATOL = MAX( TOL2, RTOL*HSV(1) ) + DO 40 J = NR1, N + IF( HSV(J).LE.ATOL ) GO TO 50 + NMINR = NMINR + 1 + 40 CONTINUE + 50 CONTINUE + END IF +C +C Compute the order of S2. +C + NS = NMINR - NR +C +C Compute the truncation matrices. +C +C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, + $ ONE, T, LDT, DWORK(KU), N ) +C +C Compute T = | T1 T2 | = Su*| U1 U2 | +C (with Su packed, if not enough workspace). +C + CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) + IF ( PACKED ) THEN + DO 60 J = 1, NMINR + CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(KV), + $ T(1,J), 1 ) + 60 CONTINUE + ELSE + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, + $ NMINR, ONE, DWORK(KV), N, T, LDT ) + END IF +C + IF( BAL ) THEN + IJ = KU +C +C Square-Root SPA method. +C +C Compute the truncation matrices for balancing +C -1/2 -1/2 +C T1*S1 and TI1'*S1 +C + DO 70 J = 1, NR + TEMP = ONE/SQRT( HSV(J) ) + CALL DSCAL( N, TEMP, T(1,J), 1 ) + CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) + IJ = IJ + N + 70 CONTINUE + ELSE +C +C Balancing-Free SPA method. +C +C Compute orthogonal bases for the images of matrices T1 and +C TI1'. +C +C Workspace: need N*MAX(N,M,P) + 2*NR; +C prefer N*MAX(N,M,P) + NR*(NB+1) +C (NB determined by ILAENV for DGEQRF). +C + KW = KTAU + NR + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) + CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF + IF( NS.GT.0 ) THEN +C +C Compute orthogonal bases for the images of matrices T2 and +C TI2'. +C +C Workspace: need N*MAX(N,M,P) + 2*NS; +C prefer N*MAX(N,M,P) + NS*(NB+1) +C (NB determined by ILAENV for DGEQRF). + KW = KTAU + NS + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), + $ DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF +C +C Transpose TI' in TI. +C + CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) +C + IF( .NOT.BAL ) THEN +C -1 +C Compute (TI1*T1) *TI1 in TI. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, + $ LDTI, T, LDT, ZERO, DWORK(KU), N ) + CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, + $ LDTI, IERR ) +C + IF( NS.GT.0 ) THEN +C -1 +C Compute (TI2*T2) *TI2 in TI2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, + $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), + $ N ) + CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, + $ TI(NR1,1), LDTI, IERR ) + END IF + END IF +C +C Compute TI*A*T (A is in RSF). +C + IJ = KU + DO 80 J = 1, N + K = MIN( J+1, N ) + CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, + $ ZERO, DWORK(IJ), 1 ) + IJ = IJ + N + 80 CONTINUE + CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, + $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) +C +C Compute TI*B and C*T. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, + $ LDTI, DWORK(KU), N, ZERO, B, LDB ) +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, + $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) +C +C Compute the singular perturbation approximation if possible. +C Note that IERR = 1 on exit from AB09DD cannot appear here. +C +C Workspace: need real 4*(NMINR-NR); +C need integer 2*(NMINR-NR). +C + CALL AB09DD( DICO, NMINR, M, P, NR, A, LDA, B, LDB, C, LDC, D, + $ LDD, RCOND, IWORK, DWORK, IERR ) +C + IWORK(1) = NMINR + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09BX *** + END diff --git a/mex/sources/libslicot/AB09CD.f b/mex/sources/libslicot/AB09CD.f new file mode 100644 index 000000000..01567db21 --- /dev/null +++ b/mex/sources/libslicot/AB09CD.f @@ -0,0 +1,375 @@ + SUBROUTINE AB09CD( DICO, EQUIL, ORDSEL, N, M, P, NR, A, LDA, B, + $ LDB, C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable +C original state-space representation (A,B,C,D) by using the +C optimal Hankel-norm approximation method in conjunction with +C square-root balancing. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), +C where KR is the multiplicity of the Hankel singular value +C HSV(NR+1), NR is the desired order on entry, and NMIN is +C the order of a minimal realization of the given system; +C NMIN is determined as the number of Hankel singular values +C greater than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL1 <= 0 on entry. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the given system. The recommended value is +C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default +C if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M), if DICO = 'C'; +C LIWORK = MAX(1,N,M), if DICO = 'D'. +C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of +C the computed minimal realization. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1, LDW2 ), where +C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, +C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is set +C automatically to a value corresponding to the order +C of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to the real Schur form failed; +C = 2: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 3: the computation of Hankel singular values failed; +C = 4: the computation of stable projection failed; +C = 5: the order of computed stable projection differs +C from the order of Hankel-norm approximation. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09CD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The optimal Hankel-norm approximation method of [1], based on the +C square-root balancing projection formulas of [2], is employed. +C +C REFERENCES +C +C [1] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [2] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, April 1998. +C Based on the RASP routine OHNAP. +C +C REVISIONS +C +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C March 26, 2005, V. Sima, Research Institute for Informatics. +C +C KEYWORDS +C +C Balancing, Hankel-norm approximation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL FIXORD + INTEGER IERR, KI, KL, KT, KW + DOUBLE PRECISION MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09CX, TB01ID, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. LSAME( DICO, 'D' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2, + $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN + INFO = -21 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Reduce A to the real Schur form using an orthogonal similarity +C transformation A <- T'*A*T and apply the transformation to B +C and C: B <- T'*B and C <- C*T. +C + KT = 1 + KL = KT + N*N + KI = KL + N + KW = KI + N + CALL TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, DWORK(KT), N, + $ DWORK(KL), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + CALL AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, C, LDC, + $ D, LDD, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, + $ IWARN, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(1) ) +C + RETURN +C *** Last line of AB09CD *** + END diff --git a/mex/sources/libslicot/AB09CX.f b/mex/sources/libslicot/AB09CX.f new file mode 100644 index 000000000..7644d7992 --- /dev/null +++ b/mex/sources/libslicot/AB09CX.f @@ -0,0 +1,558 @@ + SUBROUTINE AB09CX( DICO, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, HSV, TOL1, TOL2, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for a stable +C original state-space representation (A,B,C,D) by using the optimal +C Hankel-norm approximation method in conjunction with square-root +C balancing. The state dynamics matrix A of the original system is +C an upper quasi-triangular matrix in real Schur canonical form. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(MAX(0,NR-KR+1),NMIN), +C where KR is the multiplicity of the Hankel singular value +C HSV(NR+1), NR is the desired order on entry, and NMIN is +C the order of a minimal realization of the given system; +C NMIN is determined as the number of Hankel singular values +C greater than N*EPS*HNORM(A,B,C), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(A,B,C) is the Hankel norm of the system (computed +C in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(A,B,C)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A in a real Schur +C canonical form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values of +C the original system ordered decreasingly. HSV(1) is the +C Hankel norm of the system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(A,B,C), where c is a constant in the +C interval [0.00001,0.001], and HNORM(A,B,C) is the +C Hankel-norm of the given system (computed in HSV(1)). +C For computing a minimal realization, the recommended +C value is TOL1 = N*EPS*HNORM(A,B,C), where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH). +C This value is used by default if TOL1 <= 0 on entry. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the given system. The recommended value is +C TOL2 = N*EPS*HNORM(A,B,C). This value is used by default +C if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M), if DICO = 'C'; +C LIWORK = MAX(1,N,M), if DICO = 'D'. +C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of +C the computed minimal realization. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1,LDW2 ), where +C LDW1 = N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2, +C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is set +C automatically to a value corresponding to the order +C of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 2: the computation of Hankel singular values failed; +C = 3: the computation of stable projection failed; +C = 4: the order of computed stable projection differs +C from the order of Hankel-norm approximation. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09CX determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The optimal Hankel-norm approximation method of [1], based on the +C square-root balancing projection formulas of [2], is employed. +C +C REFERENCES +C +C [1] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [2] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, April 1998. +C Based on the RASP routine OHNAP1. +C +C REVISIONS +C +C November 11, 1998, V. Sima, Research Institute for Informatics, +C Bucharest. +C April 24, 2000, A. Varga, DLR Oberpfaffenhofen. +C April 8, 2001, A. Varga, DLR Oberpfaffenhofen. +C March 26, 2005, V. Sima, Research Institute for Informatics. +C +C KEYWORDS +C +C Balancing, Hankel-norm approximation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars + LOGICAL DISCR, FIXORD + INTEGER I, I1, IERR, IRANK, J, KB1, KB2, KC1, KC2T, + $ KHSVP, KHSVP2, KR, KT, KTI, KU, KW, KW1, KW2, + $ LDB1, LDB2, LDC1, LDC2T, NA, NDIM, NKR1, NMINR, + $ NR1, NU, WRKOPT + DOUBLE PRECISION ATOL, RTOL, SKP, SKP2, SRRTOL +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB04MD, AB09AX, DAXPY, DCOPY, DGELSY, DGEMM, + $ DLACPY, DSWAP, MA02AD, MB01SD, TB01KD, TB01WD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2, + $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09CX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + RTOL = DBLE( N )*DLAMCH( 'Epsilon' ) + SRRTOL = SQRT( RTOL ) +C +C Allocate working storage. +C + KT = 1 + KTI = KT + N*N + KW = KTI + N*N +C +C Compute a minimal order balanced realization of the given system. +C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; +C prefer larger. +C + CALL AB09AX( DICO, 'Balanced', 'Automatic', N, M, P, NMINR, A, + $ LDA, B, LDB, C, LDC, HSV, DWORK(KT), N, DWORK(KTI), + $ N, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) +C + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Compute the order of reduced system. +C + ATOL = RTOL*HSV(1) + IF( FIXORD ) THEN + IF( NR.GT.0 ) THEN + IF( NR.GT.NMINR ) THEN + NR = NMINR + IWARN = 1 + ENDIF + ENDIF + ELSE + ATOL = MAX( TOL1, ATOL ) + NR = 0 + DO 10 I = 1, NMINR + IF( HSV(I).LE.ATOL ) GO TO 20 + NR = NR + 1 + 10 CONTINUE + 20 CONTINUE + ENDIF +C + IF( NR.EQ.NMINR ) THEN + IWORK(1) = NMINR + DWORK(1) = WRKOPT + KW = N*(N+2)+1 +C +C Reduce Ar to a real Schur form. +C + CALL TB01WD( NMINR, M, P, A, LDA, B, LDB, C, LDC, + $ DWORK(2*N+1), N, DWORK, DWORK(N+1), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + RETURN + END IF + SKP = HSV(NR+1) +C +C If necessary, reduce the order such that HSV(NR) > HSV(NR+1). +C + 30 IF( NR.GT.0 ) THEN + IF( ABS( HSV(NR)-SKP ).LE.SRRTOL*SKP ) THEN + NR = NR - 1 + GO TO 30 + END IF + END IF +C +C Determine KR, the multiplicity of HSV(NR+1). +C + KR = 1 + DO 40 I = NR+2, NMINR + IF( ABS( HSV(I)-SKP ).GT.SRRTOL*SKP ) GO TO 50 + KR = KR + 1 + 40 CONTINUE + 50 CONTINUE +C +C For discrete-time case, apply the discrete-to-continuous bilinear +C transformation. +C + IF( DISCR ) THEN +C +C Workspace: need N; +C prefer larger. +C + CALL AB04MD( 'Discrete', NMINR, M, P, ONE, ONE, A, LDA, B, LDB, + $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C +C Define leading dimensions and offsets for temporary data. +C + NU = NMINR - NR - KR + NA = NR + NU + LDB1 = NA + LDC1 = P + LDB2 = KR + LDC2T = MAX( KR, M ) + NR1 = NR + 1 + NKR1 = MIN( NMINR, NR1 + KR ) +C + KHSVP = 1 + KHSVP2 = KHSVP + NA + KU = KHSVP2 + NA + KB1 = KU + P*M + KB2 = KB1 + LDB1*M + KC1 = KB2 + LDB2*M + KC2T = KC1 + LDC1*NA + KW = KC2T + LDC2T*P +C +C Save B2 and C2'. +C + CALL DLACPY( 'Full', KR, M, B(NR1,1), LDB, DWORK(KB2), LDB2 ) + CALL MA02AD( 'Full', P, KR, C(1,NR1), LDC, DWORK(KC2T), LDC2T ) + IF( NR.GT.0 ) THEN +C +C Permute the elements of HSV and of matrices A, B, C. +C + CALL DCOPY( NR, HSV(1), 1, DWORK(KHSVP), 1 ) + CALL DCOPY( NU, HSV(NKR1), 1, DWORK(KHSVP+NR), 1 ) + CALL DLACPY( 'Full', NMINR, NU, A(1,NKR1), LDA, A(1,NR1), LDA ) + CALL DLACPY( 'Full', NU, NA, A(NKR1,1), LDA, A(NR1,1), LDA ) + CALL DLACPY( 'Full', NU, M, B(NKR1,1), LDB, B(NR1,1), LDB ) + CALL DLACPY( 'Full', P, NU, C(1,NKR1), LDC, C(1,NR1), LDC ) +C +C Save B1 and C1. +C + CALL DLACPY( 'Full', NA, M, B, LDB, DWORK(KB1), LDB1 ) + CALL DLACPY( 'Full', P, NA, C, LDC, DWORK(KC1), LDC1 ) + END IF +C +C Compute U = C2*pinv(B2'). +C Workspace: need N*(M+P+2) + 2*M*P + +C max(min(KR,M)+3*M+1,2*min(KR,M)+P); +C prefer N*(M+P+2) + 2*M*P + +C max(min(KR,M)+2*M+(M+1)*NB,2*min(KR,M)+P*NB), +C where NB is the maximum of the block sizes for +C DGEQP3, DTZRZF, DTZRQF, DORMQR, and DORMRZ. +C + DO 55 J = 1, M + IWORK(J) = 0 + 55 CONTINUE + CALL DGELSY( KR, M, P, DWORK(KB2), LDB2, DWORK(KC2T), LDC2T, + $ IWORK, RTOL, IRANK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL MA02AD( 'Full', M, P, DWORK(KC2T), LDC2T, DWORK(KU), P ) +C +C Compute D <- D + HSV(NR+1)*U. +C + I = KU + DO 60 J = 1, M + CALL DAXPY( P, SKP, DWORK(I), 1, D(1,J), 1 ) + I = I + P + 60 CONTINUE +C + IF( NR.GT.0 ) THEN + SKP2 = SKP*SKP +C +C Compute G = inv(S1*S1-skp*skp*I), where S1 is the diagonal +C matrix of relevant singular values (of order NMINR - KR). +C + I1 = KHSVP2 + DO 70 I = KHSVP, KHSVP+NA-1 + DWORK(I1) = ONE / ( DWORK(I)*DWORK(I) - SKP2 ) + I1 = I1 + 1 + 70 CONTINUE +C +C Compute C <- C1*S1-skp*U*B1'. +C + CALL MB01SD( 'Column', P, NA, C, LDC, DWORK, DWORK(KHSVP) ) + CALL DGEMM( 'NoTranspose', 'Transpose', P, NA, M, -SKP, + $ DWORK(KU), P, DWORK(KB1), LDB1, ONE, C, LDC ) +C +C Compute B <- G*(S1*B1-skp*C1'*U). +C + CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP), DWORK ) + CALL DGEMM( 'Transpose', 'NoTranspose', NA, M, P, -SKP, + $ DWORK(KC1), LDC1, DWORK(KU), P, ONE, B, LDB ) + CALL MB01SD( 'Row', NA, M, B, LDB, DWORK(KHSVP2), DWORK ) +C +C Compute A <- -A1' - B*B1'. +C + DO 80 J = 2, NA + CALL DSWAP( J-1, A(1,J), 1, A(J,1), LDA ) + 80 CONTINUE + CALL DGEMM( 'NoTranspose', 'Transpose', NA, NA, M, -ONE, B, + $ LDB, DWORK(KB1), LDB1, -ONE, A, LDA ) +C +C Extract stable part. +C Workspace: need N*N+5*N; +C prefer larger. +C + KW1 = NA*NA + 1 + KW2 = KW1 + NA + KW = KW2 + NA + CALL TB01KD( 'Continuous', 'Stability', 'General', NA, M, P, + $ ZERO, A, LDA, B, LDB, C, LDC, NDIM, DWORK, NA, + $ DWORK(KW1), DWORK(KW2), DWORK(KW), LDWORK-KW+1, + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C + IF( NDIM.NE.NR ) THEN + INFO = 4 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C For discrete-time case, apply the continuous-to-discrete +C bilinear transformation. +C + IF( DISCR ) + $ CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, + $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, + $ INFO ) + END IF + IWORK(1) = NMINR + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09CX *** + END diff --git a/mex/sources/libslicot/AB09DD.f b/mex/sources/libslicot/AB09DD.f new file mode 100644 index 000000000..0ba78924c --- /dev/null +++ b/mex/sources/libslicot/AB09DD.f @@ -0,0 +1,278 @@ + SUBROUTINE AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, + $ D, LDD, RCOND, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model by using singular perturbation +C approximation formulas. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A; also the number of rows of matrix B and the +C number of columns of the matrix C. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of matrices B and D. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows of +C matrices C and D. P >= 0. +C +C NR (input) INTEGER +C The order of the reduced order system. N >= NR >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix of the original system. +C On exit, the leading NR-by-NR part of this array contains +C the state dynamics matrix Ar of the reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix of the original system. +C On exit, the leading NR-by-M part of this array contains +C the input/state matrix Br of the reduced order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix of the original system. +C On exit, the leading P-by-NR part of this array contains +C the state/output matrix Cr of the reduced order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix of the original system. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix Dr of the reduced order system. +C If NR = 0 and the given system is stable, then D contains +C the steady state gain of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal condition number of the matrix A22-g*I +C (see METHOD). +C +C Workspace +C +C IWORK INTEGER array, dimension 2*(N-NR) +C +C DWORK DOUBLE PRECISION array, dimension 4*(N-NR) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix A22-g*I (see METHOD) is numerically +C singular. +C +C METHOD +C +C Given the system (A,B,C,D), partition the system matrices as +C +C ( A11 A12 ) ( B1 ) +C A = ( ) , B = ( ) , C = ( C1 C2 ), +C ( A21 A22 ) ( B2 ) +C +C where A11 is NR-by-NR, B1 is NR-by-M, C1 is P-by-NR, and the other +C submatrices have appropriate dimensions. +C +C The matrices of the reduced order system (Ar,Br,Cr,Dr) are +C computed according to the following residualization formulas: +C -1 -1 +C Ar = A11 + A12*(g*I-A22) *A21 , Br = B1 + A12*(g*I-A22) *B2 +C -1 -1 +C Cr = C1 + C2*(g*I-A22) *A21 , Dr = D + C2*(g*I-A22) *B2 +C +C where g = 0 if DICO = 'C' and g = 1 if DICO = 'D'. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRESID. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Model reduction, multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, LDA, LDB, LDC, LDD, M, N, NR, P + DOUBLE PRECISION RCOND +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) + INTEGER IWORK(*) +C .. Local Scalars + LOGICAL DISCR + INTEGER I, J, K, NS + DOUBLE PRECISION A22NRM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( NR.LT.0 .OR. NR.GT.N ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( NR.EQ.N ) THEN + RCOND = ONE + RETURN + END IF +C + K = NR + 1 + NS = N - NR +C +C Compute: T = -A22 if DICO = 'C' and +C T = -A22+I if DICO = 'D'. +C + DO 20 J = K, N + DO 10 I = K, N + A(I,J) = -A(I,J) + 10 CONTINUE + IF( DISCR ) A(J,J) = A(J,J) + ONE + 20 CONTINUE +C +C Compute the LU decomposition of T. +C + A22NRM = DLANGE( '1-norm', NS, NS, A(K,K), LDA, DWORK ) + CALL DGETRF( NS, NS, A(K,K), LDA, IWORK, INFO ) + IF( INFO.GT.0 ) THEN +C +C Error return. +C + RCOND = ZERO + INFO = 1 + RETURN + END IF + CALL DGECON( '1-norm', NS, A(K,K), LDA, A22NRM, RCOND, DWORK, + $ IWORK(NS+1), INFO ) + IF( RCOND.LE.DLAMCH('E') ) THEN +C +C Error return. +C + INFO = 1 + RETURN + END IF +C +C Compute A21 <- INV(T)*A21. +C + CALL DGETRS( 'NoTranspose', NS, NR, A(K,K), LDA, IWORK, A(K,1), + $ LDA, INFO ) +C +C Compute B2 <- INV(T)*B2. +C + CALL DGETRS( 'NoTranspose', NS, M, A(K,K), LDA, IWORK, B(K,1), + $ LDB, INFO ) +C +C Compute the residualized systems matrices. +C Ar = A11 + A12*INV(T)*A21. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, NS, ONE, A(1,K), + $ LDA, A(K,1), LDA, ONE, A, LDA ) +C +C Br = B1 + A12*INV(T)*B2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, M, NS, ONE, A(1,K), + $ LDA, B(K,1), LDB, ONE, B, LDB ) +C +C Cr = C1 + C2*INV(T)*A21. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NR, NS, ONE, C(1,K), + $ LDC, A(K,1), LDA, ONE, C, LDC ) +C +C Dr = D + C2*INV(T)*B2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, M, NS, ONE, C(1,K), + $ LDC, B(K,1), LDB, ONE, D, LDD ) +C + RETURN +C *** Last line of AB09DD *** + END diff --git a/mex/sources/libslicot/AB09ED.f b/mex/sources/libslicot/AB09ED.f new file mode 100644 index 000000000..7c3afb8e4 --- /dev/null +++ b/mex/sources/libslicot/AB09ED.f @@ -0,0 +1,493 @@ + SUBROUTINE AB09ED( DICO, EQUIL, ORDSEL, N, M, P, NR, ALPHA, + $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the optimal +C Hankel-norm approximation method in conjunction with square-root +C balancing for the ALPHA-stable part of the system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the +C multiplicity of the Hankel singular value HSV(NR-NU+1), +C NR is the desired order on entry, and NMIN is the order +C of a minimal realization of the ALPHA-stable part of the +C given system; NMIN is determined as the number of Hankel +C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where +C EPS is the machine precision (see LAPACK Library Routine +C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the +C ALPHA-stable part of the given system (computed in +C HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the ALPHA-stable part of the +C original system ordered decreasingly. +C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the +C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the +C Hankel-norm of the ALPHA-stable part of the given system +C (computed in HSV(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C This value is appropriate to compute a minimal realization +C of the ALPHA-stable part. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M), if DICO = 'C'; +C LIWORK = MAX(1,N,M), if DICO = 'D'. +C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of +C the computed minimal realization. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1, LDW2 ), where +C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system. In this case, the resulting NR is set equal +C to NSMIN. +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system. In this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 3: the computed ALPHA-stable part is just stable, +C having stable eigenvalues very near to the imaginary +C axis (if DICO = 'C') or to the unit circle +C (if DICO = 'D'); +C = 4: the computation of Hankel singular values failed; +C = 5: the computation of stable projection in the +C Hankel-norm approximation algorithm failed; +C = 6: the order of computed stable projection in the +C Hankel-norm approximation algorithm differs +C from the order of Hankel-norm approximation. +C +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09ED determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The following procedure is used to reduce a given G: +C +C 1) Decompose additively G as +C +C G = G1 + G2 +C +C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. +C +C 2) Determine G1r, a reduced order approximation of the +C ALPHA-stable part G1. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the ALPHA-stable part G1, the optimal Hankel-norm +C approximation method of [1], based on the square-root +C balancing projection formulas of [2], is employed. +C +C REFERENCES +C +C [1] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [2] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routines SADSDC and OHNAP. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. +C March 26, 2005, V. Sima, Research Institute for Informatics. +C +C KEYWORDS +C +C Balancing, Hankel-norm approximation, model reduction, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, NS, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD + INTEGER IERR, IWARNL, KI, KL, KU, KW, NRA, NU, NU1 + DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09CX, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -20 + ELSE IF( LDWORK.LT.MAX( N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2, + $ N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) ) THEN + INFO = -23 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NS = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + KU = 1 + KL = KU + N*N + KI = KL + N + KW = KI + N +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), + $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Determine a reduced order approximation of the ALPHA-stable part. +C +C Workspace: need MAX( LDW1, LDW2 ), +C LDW1 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW2 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ); +C prefer larger. +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 + CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) +C + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN + INFO = IERR + 2 + RETURN + END IF +C + NR = NRA + NU +C + DWORK(1) = MAX( WRKOPT, DWORK(1) ) +C + RETURN +C *** Last line of AB09ED *** + END diff --git a/mex/sources/libslicot/AB09FD.f b/mex/sources/libslicot/AB09FD.f new file mode 100644 index 000000000..cb954ba15 --- /dev/null +++ b/mex/sources/libslicot/AB09FD.f @@ -0,0 +1,649 @@ + SUBROUTINE AB09FD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, + $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, NQ, HSV, + $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr) for an original +C state-space representation (A,B,C) by using either the square-root +C or the balancing-free square-root Balance & Truncate (B & T) +C model reduction method in conjunction with stable coprime +C factorization techniques. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBCF CHARACTER*1 +C Specifies whether left or right coprime factorization is +C to be used as follows: +C = 'L': use left coprime factorization; +C = 'R': use right coprime factorization. +C +C FACT CHARACTER*1 +C Specifies the type of coprime factorization to be computed +C as follows: +C = 'S': compute a coprime factorization with prescribed +C stability degree ALPHA; +C = 'I': compute a coprime factorization with inner +C denominator. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR +C is the desired order on entry, NQ is the order of the +C computed coprime factorization of the given system, and +C NMIN is the order of a minimal realization of the extended +C system (see METHOD); NMIN is determined as the number of +C Hankel singular values greater than NQ*EPS*HNORM(Ge), +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the +C extended system (computed in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). +C +C ALPHA (input) DOUBLE PRECISION +C If FACT = 'S', the desired stability degree for the +C factors of the coprime factorization (see SLICOT Library +C routines SB08ED/SB08FD). +C ALPHA < 0 for a continuous-time system (DICO = 'C'), and +C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). +C If FACT = 'I', ALPHA is not used. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the computed extended system Ge (see METHOD). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the NQ Hankel singular values of +C the extended system Ge ordered decreasingly (see METHOD). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced extended system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(Ge), where c is a constant in the +C interval [0.00001,0.001], and HNORM(Ge) is the +C Hankel-norm of the extended system (computed in HSV(1)). +C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if +C TOL1 <= 0 on entry, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B or C are considered zero (used for controllability or +C observability tests). +C If the user sets TOL2 <= 0, then an implicitly computed, +C default tolerance TOLDEF is used: +C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or +C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', +C where EPS is the machine precision, and NORM(.) denotes +C the 1-norm of a matrix. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = PM, if JOBMR = 'B', +C LIWORK = MAX(N,PM), if JOBMR = 'N', where +C PM = P, if JOBCF = 'L', +C PM = M, if JOBCF = 'R'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S', +C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', +C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', +C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where +C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + +C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), +C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + +C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), +C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), +C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and +C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 10*K+I: +C I = 1: with ORDSEL = 'F', the selected order NR is +C greater than the order of the computed coprime +C factorization of the given system. In this case, +C the resulting NR is set automatically to a value +C corresponding to the order of a minimal +C realization of the system; +C K > 0: K violations of the numerical stability +C condition occured when computing the coprime +C factorization using pole assignment (see SLICOT +C Library routines SB08CD/SB08ED, SB08DD/SB08FD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + H*C)*Z +C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT +C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); +C = 3: the matrix A has an observable or controllable +C eigenvalue on the imaginary axis if DICO = 'C' or +C on the unit circle if DICO = 'D'; +C = 4: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let G be the corresponding +C transfer-function matrix. The subroutine AB09FD determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) (2) +C +C with the transfer-function matrix Gr, by using the +C balanced-truncation model reduction method in conjunction with +C a left coprime factorization (LCF) or a right coprime +C factorization (RCF) technique: +C +C 1. Compute the appropriate stable coprime factorization of G: +C -1 -1 +C G = R *Q (LCF) or G = Q*R (RCF). +C +C 2. Perform the model reduction algorithm on the extended system +C ( Q ) +C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) +C +C to obtain a reduced extended system with reduced factors +C ( Qr ) +C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). +C +C 3. Recover the reduced system from the reduced factors as +C -1 -1 +C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). +C +C The approximation error for the extended system satisfies +C +C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], +C +C where INFNORM(G) is the infinity-norm of G. +C +C If JOBMR = 'B', the square-root Balance & Truncate method of [1] +C is used for model reduction. +C If JOBMR = 'N', the balancing-free square-root version of the +C Balance & Truncate method [2] is used for model reduction. +C +C If FACT = 'S', the stable coprime factorization with prescribed +C stability degree ALPHA is computed by using the algorithm of [3]. +C If FACT = 'I', the stable coprime factorization with inner +C denominator is computed by using the algorithm of [4]. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, +C pp. 42-46, 1991. +C +C [3] Varga A. +C Coprime factors model reduction method based on square-root +C balancing-free techniques. +C System Analysis, Modelling and Simulation, Vol. 11, +C pp. 303-311, 1993. +C +C [4] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, August 1998. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C +C KEYWORDS +C +C Balancing, coprime factorization, minimal realization, +C model reduction, multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NQ, + $ NR, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD, LEFT, STABD + INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, + $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, + $ MAXMP, MP, NDR, PM, WRKOPT + DOUBLE PRECISION MAXRED +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09AX, DLACPY, DLASET, SB08CD, SB08DD, SB08ED, + $ SB08FD, SB08GD, SB08HD, TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFT = LSAME( JOBCF, 'L' ) + STABD = LSAME( FACT, 'S' ) + MAXMP = MAX( M, P ) +C + LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 + LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) + LW2 = LW1 + + $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) + LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) + LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) + LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. + $ LSAME( JOBMR, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -6 + ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. + $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) + $ THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -11 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( ( LDWORK.LT.1 ) .OR. + $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. + $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. + $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. + $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN + INFO = -24 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. ( FIXORD .AND. NR.EQ.0 ) ) THEN + NR = 0 + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Perform the coprime factor model reduction procedure. +C + KD = 1 + IF( LEFT ) THEN +C -1 +C Compute a LCF G = R *Q. +C + MP = M + P + KDR = KD + MAXMP*MAXMP + KC = KDR + MAXMP*P + KB = KC + MAXMP*N + KBR = KB + N*MAXMP + KW = KBR + N*P + LWR = LDWORK - KW + 1 + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) + CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), MAXMP ) +C + IF( STABD ) THEN +C +C Compute a LCF with prescribed stability degree. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); +C prefer larger. +C + CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, + $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, + $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, + $ DWORK(KW), LWR, IWARN, INFO ) + ELSE +C +C Compute a LCF with inner denominator. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need N*P + +C MAX(N*(N+5),P*(P+2),4*P,4*M). +C prefer larger; +C + CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, + $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, + $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL2, + $ DWORK(KW), LWR, IWARN, INFO ) + END IF +C + IWARN = 10*IWARN + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IF( NQ.EQ.0 ) THEN + NR = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C + IF( MAXMP.GT.M ) THEN +C +C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive +C columns (see SLICOT Library routines SB08CD/SB08ED). +C + KBT = KBR + KBR = KB + N*M + KDT = KDR + KDR = KD + MAXMP*M + CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) + CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), + $ MAXMP ) + END IF +C +C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; +C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; +C prefer larger. +C + KT = KW + KTI = KT + NQ*NQ + KW = KTI + NQ*NQ + CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, + $ DWORK(KB), N, DWORK(KC), MAXMP, HSV, DWORK(KT), + $ N, DWORK(KTI), N, TOL1, IWORK, DWORK(KW), + $ LDWORK-KW+1, IWARNK, IERR ) +C + IWARN = IWARN + IWARNK + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C -1 +C Compute the reduced order system Gr = Rr *Qr. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need 4*P. +C + KW = KT + CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, + $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), + $ MAXMP, IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Br and Cr to B and C. +C + CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) + CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) +C + ELSE +C -1 +C Compute a RCF G = Q*R . +C + PM = P + M + KDR = KD + P + KC = KD + PM*M + KCR = KC + P + KW = KC + PM*N + LWR = LDWORK - KW + 1 + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) + CALL DLASET( 'Full', P, M, ZERO, ZERO, DWORK(KD), PM ) +C + IF( STABD ) THEN +C +C Compute a RCF with prescribed stability degree. +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); +C prefer larger. +C + CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, + $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, + $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, + $ DWORK(KW), LWR, IWARN, INFO ) + ELSE +C +C Compute a RCF with inner denominator. +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need MAX(N*(N+5),M*(M+2),4*M,4*P); +C prefer larger. +C + CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, + $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, + $ DWORK(KCR), PM, DWORK(KDR), PM, TOL2, + $ DWORK(KW), LWR, IWARN, INFO ) + END IF +C + IWARN = 10*IWARN + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IF( NQ.EQ.0 ) THEN + NR = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C ( Q ) ( Qr ) +C Perform model reduction on ( R ) to determine ( Rr ). +C +C Workspace needed: (N+M)*(M+P) + 2*N*N; +C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; +C prefer larger. +C + KT = KW + KTI = KT + NQ*NQ + KW = KTI + NQ*NQ + CALL AB09AX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, B, + $ LDB, DWORK(KC), PM, HSV, DWORK(KT), N, DWORK(KTI), + $ N, TOL1, IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, + $ IERR ) +C + IWARN = IWARN + IWARNK + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C -1 +C Compute the reduced order system Gr = Qr*Rr . +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need 4*M. +C + KW = KT + CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, + $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, + $ IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrix Cr to C. +C + CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09FD *** + END diff --git a/mex/sources/libslicot/AB09GD.f b/mex/sources/libslicot/AB09GD.f new file mode 100644 index 000000000..c55160369 --- /dev/null +++ b/mex/sources/libslicot/AB09GD.f @@ -0,0 +1,681 @@ + SUBROUTINE AB09GD( DICO, JOBCF, FACT, JOBMR, EQUIL, ORDSEL, N, M, + $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, HSV, TOL1, TOL2, TOL3, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using either the +C square-root or the balancing-free square-root Singular +C Perturbation Approximation (SPA) model reduction method in +C conjunction with stable coprime factorization techniques. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBCF CHARACTER*1 +C Specifies whether left or right coprime factorization is +C to be used as follows: +C = 'L': use left coprime factorization; +C = 'R': use right coprime factorization. +C +C FACT CHARACTER*1 +C Specifies the type of coprime factorization to be computed +C as follows: +C = 'S': compute a coprime factorization with prescribed +C stability degree ALPHA; +C = 'I': compute a coprime factorization with inner +C denominator. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NQ,NMIN), where NR +C is the desired order on entry, NQ is the order of the +C computed coprime factorization of the given system, and +C NMIN is the order of a minimal realization of the extended +C system (see METHOD); NMIN is determined as the number of +C Hankel singular values greater than NQ*EPS*HNORM(Ge), +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the +C extended system (computed in HSV(1)); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,NQ*EPS*HNORM(Ge)). +C +C ALPHA (input) DOUBLE PRECISION +C If FACT = 'S', the desired stability degree for the +C factors of the coprime factorization (see SLICOT Library +C routines SB08ED/SB08FD). +C ALPHA < 0 for a continuous-time system (DICO = 'C'), and +C 0 <= ALPHA < 1 for a discrete-time system (DICO = 'D'). +C If FACT = 'I', ALPHA is not used. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the computed extended system Ge (see METHOD). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the NQ Hankel singular values of +C the extended system Ge ordered decreasingly (see METHOD). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced extended system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(Ge), where c is a constant in the +C interval [0.00001,0.001], and HNORM(Ge) is the +C Hankel-norm of the extended system (computed in HSV(1)). +C The value TOL1 = NQ*EPS*HNORM(Ge) is used by default if +C TOL1 <= 0 on entry, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the extended system Ge (see METHOD). +C The recommended value is TOL2 = NQ*EPS*HNORM(Ge). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C TOL3 DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B or C are considered zero (used for controllability or +C observability tests by the coprime factorization method). +C If the user sets TOL3 <= 0, then an implicitly computed, +C default tolerance TOLDEF is used: +C TOLDEF = N*EPS*NORM(C'), if JOBCF = 'L', or +C TOLDEF = N*EPS*NORM(B), if JOBCF = 'R', +C where EPS is the machine precision, and NORM(.) denotes +C the 1-norm of a matrix. +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(1,2*N,PM)) +C where PM = P, if JOBCF = 'L', +C PM = M, if JOBCF = 'R'. +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,LW1) if JOBCF = 'L' and FACT = 'S', +C LDWORK >= MAX(1,LW2) if JOBCF = 'L' and FACT = 'I', +C LDWORK >= MAX(1,LW3) if JOBCF = 'R' and FACT = 'S', +C LDWORK >= MAX(1,LW4) if JOBCF = 'R' and FACT = 'I', where +C LW1 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + +C MAX( N*P+MAX(N*(N+5), 5*P, 4*M), LWR ), +C LW2 = N*(2*MAX(M,P) + P) + MAX(M,P)*(MAX(M,P) + P) + +C MAX( N*P+MAX(N*(N+5), P*(P+2), 4*P, 4*M), LWR ), +C LW3 = (N+M)*(M+P) + MAX( 5*M, 4*P, LWR ), +C LW4 = (N+M)*(M+P) + MAX( M*(M+2), 4*M, 4*P, LWR ), and +C LWR = 2*N*N + N*(MAX(N,M+P)+5) + N*(N+1)/2. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 10*K+I: +C I = 1: with ORDSEL = 'F', the selected order NR is +C greater than the order of the computed coprime +C factorization of the given system. In this case, +C the resulting NR is set automatically to a value +C corresponding to the order of a minimal +C realization of the system; +C K > 0: K violations of the numerical stability +C condition occured when computing the coprime +C factorization using pole assignment (see SLICOT +C Library routines SB08CD/SB08ED, SB08DD/SB08FD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + H*C)*Z +C (or Z'*(A + B*F)*Z) along the diagonal; see SLICOT +C Library routines SB08CD/SB08ED (or SB08DD/SB08FD); +C = 3: the matrix A has an observable or controllable +C eigenvalue on the imaginary axis if DICO = 'C' or +C on the unit circle if DICO = 'D'; +C = 4: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let G be the corresponding +C transfer-function matrix. The subroutine AB09GD determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C with the transfer-function matrix Gr, by using the +C singular perturbation approximation (SPA) method in conjunction +C with a left coprime factorization (LCF) or a right coprime +C factorization (RCF) technique: +C +C 1. Compute the appropriate stable coprime factorization of G: +C -1 -1 +C G = R *Q (LCF) or G = Q*R (RCF). +C +C 2. Perform the model reduction algorithm on the extended system +C ( Q ) +C Ge = ( Q R ) (LCF) or Ge = ( R ) (RCF) +C +C to obtain a reduced extended system with reduced factors +C ( Qr ) +C Ger = ( Qr Rr ) (LCF) or Ger = ( Rr ) (RCF). +C +C 3. Recover the reduced system from the reduced factors as +C -1 -1 +C Gr = Rr *Qr (LCF) or Gr = Qr*Rr (RCF). +C +C The approximation error for the extended system satisfies +C +C HSV(NR) <= INFNORM(Ge-Ger) <= 2*[HSV(NR+1) + ... + HSV(NQ)], +C +C where INFNORM(G) is the infinity-norm of G. +C +C If JOBMR = 'B', the balancing-based square-root SPA method of [1] +C is used for model reduction. +C If JOBMR = 'N', the balancing-free square-root SPA method of [2] +C is used for model reduction. +C By setting TOL1 = TOL2, the routine can be used to compute +C Balance & Truncate approximations. +C +C If FACT = 'S', the stable coprime factorization with prescribed +C stability degree ALPHA is computed by using the algorithm of [3]. +C If FACT = 'I', the stable coprime factorization with inner +C denominator is computed by using the algorithm of [4]. +C +C REFERENCES +C +C [1] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of Balanced Systems. +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [2] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, Vol. 2, +C pp. 1062-1065. +C +C [3] Varga A. +C Coprime factors model reduction method based on square-root +C balancing-free techniques. +C System Analysis, Modelling and Simulation, Vol. 11, +C pp. 303-311, 1993. +C +C [4] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, August 1998. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C +C KEYWORDS +C +C Balancing, coprime factorization, minimal realization, +C model reduction, multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, C100, ZERO + PARAMETER ( ONE = 1.0D0, C100 = 100.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, FACT, JOBCF, JOBMR, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, N, + $ NQ, NR, P + DOUBLE PRECISION ALPHA, TOL1, TOL2, TOL3 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD, LEFT, STABD + INTEGER IERR, IWARNK, KB, KBR, KBT, KC, KCR, KD, KDR, + $ KDT, KT, KTI, KW, LW1, LW2, LW3, LW4, LWR, + $ MAXMP, MP, NDR, NMINR, PM, WRKOPT + DOUBLE PRECISION MAXRED +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09BX, DLACPY, SB08CD, SB08DD, SB08ED, SB08FD, + $ SB08GD, SB08HD, TB01ID, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFT = LSAME( JOBCF, 'L' ) + STABD = LSAME( FACT, 'S' ) + MAXMP = MAX( M, P ) +C + LWR = 2*N*N + N*( MAX( N, M + P ) + 5 ) + ( N*( N + 1 ) )/2 + LW1 = N*( 2*MAXMP + P ) + MAXMP*( MAXMP + P ) + LW2 = LW1 + + $ MAX( N*P + MAX( N*( N + 5 ), P*( P+2 ), 4*P, 4*M ), LWR ) + LW1 = LW1 + MAX( N*P + MAX( N*( N + 5 ), 5*P, 4*M ), LWR ) + LW3 = ( N + M )*( M + P ) + MAX( 5*M, 4*P, LWR ) + LW4 = ( N + M )*( M + P ) + MAX( M*( M + 2 ), 4*M, 4*P, LWR ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( STABD .OR. LSAME( FACT, 'I' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( JOBMR, 'B' ) .OR. + $ LSAME( JOBMR, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -6 + ELSE IF( STABD .AND. ( ( .NOT.DISCR .AND. ALPHA.GE.ZERO ) .OR. + $ ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GE.ONE ) ) ) ) + $ THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -11 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -23 + ELSE IF( ( LDWORK.LT.1 ) .OR. + $ ( STABD .AND. LEFT .AND. LDWORK.LT.LW1 ) .OR. + $ ( .NOT.STABD .AND. LEFT .AND. LDWORK.LT.LW2 ) .OR. + $ ( STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW3 ) .OR. + $ ( .NOT.STABD .AND. .NOT.LEFT .AND. LDWORK.LT.LW4 ) ) THEN + INFO = -27 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09GD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NQ = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C + MAXRED = C100 + CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Perform the coprime factor model reduction procedure. +C + KD = 1 + IF( LEFT ) THEN +C -1 +C Compute a LCF G = R *Q. +C + MP = M + P + KDR = KD + MAXMP*MAXMP + KC = KDR + MAXMP*P + KB = KC + MAXMP*N + KBR = KB + N*MAXMP + KW = KBR + N*P + LWR = LDWORK - KW + 1 + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KB), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), MAXMP ) + CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), MAXMP ) +C + IF( STABD ) THEN +C +C Compute a LCF with prescribed stability degree. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need N*P+MAX(N*(N+5),5*P,4*M); +C prefer larger. +C + CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, DWORK(KB), N, + $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, + $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, + $ DWORK(KW), LWR, IWARN, INFO ) + ELSE +C +C Compute a LCF with inner denominator. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need N*P + +C MAX(N*(N+5),P*(P+2),4*P,4*M); +C prefer larger. +C + CALL SB08CD( DICO, N, M, P, A, LDA, DWORK(KB), N, + $ DWORK(KC), MAXMP, DWORK(KD), MAXMP, NQ, NDR, + $ DWORK(KBR), N, DWORK(KDR), MAXMP, TOL3, + $ DWORK(KW), LWR, IWARN, INFO ) + END IF +C + IWARN = 10*IWARN + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IF( NQ.EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C + IF( MAXMP.GT.M ) THEN +C +C Form the matrices ( BQ, BR ) and ( DQ, DR ) in consecutive +C columns (see SLICOT Library routines SB08CD/SB08ED). +C + KBT = KBR + KBR = KB + N*M + KDT = KDR + KDR = KD + MAXMP*M + CALL DLACPY( 'Full', NQ, P, DWORK(KBT), N, DWORK(KBR), N ) + CALL DLACPY( 'Full', P, P, DWORK(KDT), MAXMP, DWORK(KDR), + $ MAXMP ) + END IF +C +C Perform model reduction on ( Q, R ) to determine ( Qr, Rr ). +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P) + 2*N*N; +C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; +C prefer larger. +C + KT = KW + KTI = KT + NQ*NQ + KW = KTI + NQ*NQ + CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, MP, P, NR, A, LDA, + $ DWORK(KB), N, DWORK(KC), MAXMP, DWORK(KD), MAXMP, + $ HSV, DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, + $ IWORK, DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) +C + IWARN = IWARN + IWARNK + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C + NMINR = IWORK(1) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C -1 +C Compute the reduced order system Gr = Rr *Qr. +C +C Workspace needed: N*(2*MAX(M,P)+P) + +C MAX(M,P)*(MAX(M,P)+P); +C Additional workspace: need 4*P. +C + KW = KT + CALL SB08GD( NR, M, P, A, LDA, DWORK(KB), N, DWORK(KC), MAXMP, + $ DWORK(KD), MAXMP, DWORK(KBR), N, DWORK(KDR), + $ MAXMP, IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Br, Cr, and Dr to B, C, and D, +C respectively. +C + CALL DLACPY( 'Full', NR, M, DWORK(KB), N, B, LDB ) + CALL DLACPY( 'Full', P, NR, DWORK(KC), MAXMP, C, LDC ) + CALL DLACPY( 'Full', P, M, DWORK(KD), MAXMP, D, LDD ) + ELSE +C -1 +C Compute a RCF G = Q*R . +C + PM = P + M + KDR = KD + P + KC = KD + PM*M + KCR = KC + P + KW = KC + PM*N + LWR = LDWORK - KW + 1 + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KC), PM ) + CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KD), PM ) +C + IF( STABD ) THEN +C +C Compute a RCF with prescribed stability degree. +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need MAX( N*(N+5), 5*M, 4*P ); +C prefer larger. +C + CALL SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, + $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, + $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, + $ DWORK(KW), LWR, IWARN, INFO) + ELSE +C +C Compute a RCF with inner denominator. +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need MAX(N*(N+5),M*(M+2),4*M,4*P); +C prefer larger. +C + CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, + $ DWORK(KC), PM, DWORK(KD), PM, NQ, NDR, + $ DWORK(KCR), PM, DWORK(KDR), PM, TOL3, + $ DWORK(KW), LWR, IWARN, INFO) + END IF +C + IWARN = 10*IWARN + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IF( NQ.EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C ( Q ) ( Qr ) +C Perform model reduction on ( R ) to determine ( Rr ). +C +C Workspace needed: (N+M)*(M+P) + 2*N*N; +C Additional workspace: need N*(MAX(N,M+P)+5) + N*(N+1)/2; +C prefer larger. +C + KT = KW + KTI = KT + NQ*NQ + KW = KTI + NQ*NQ + CALL AB09BX( DICO, JOBMR, ORDSEL, NQ, M, PM, NR, A, LDA, + $ B, LDB, DWORK(KC), PM, DWORK(KD), PM, HSV, + $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, + $ DWORK(KW), LDWORK-KW+1, IWARNK, IERR ) +C + IWARN = IWARN + IWARNK + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C + NMINR = IWORK(1) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C -1 +C Compute the reduced order system Gr = Qr*Rr . +C +C Workspace needed: (N+M)*(M+P); +C Additional workspace: need 4*M. +C + KW = KT + CALL SB08HD( NR, M, P, A, LDA, B, LDB, DWORK(KC), PM, + $ DWORK(KD), PM, DWORK(KCR), PM, DWORK(KDR), PM, + $ IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Cr and Dr to C and D. +C + CALL DLACPY( 'Full', P, NR, DWORK(KC), PM, C, LDC ) + CALL DLACPY( 'Full', P, M, DWORK(KD), PM, D, LDD ) + END IF +C + IWORK(1) = NMINR + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09GD *** + END diff --git a/mex/sources/libslicot/AB09HD.f b/mex/sources/libslicot/AB09HD.f new file mode 100644 index 000000000..1468accc6 --- /dev/null +++ b/mex/sources/libslicot/AB09HD.f @@ -0,0 +1,671 @@ + SUBROUTINE AB09HD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, + $ BETA, A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, + $ TOL1, TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the stochastic +C balancing approach in conjunction with the square-root or +C the balancing-free square-root Balance & Truncate (B&T) +C or Singular Perturbation Approximation (SPA) model reduction +C methods for the ALPHA-stable part of the system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'F': use the balancing-free square-root +C Balance & Truncate method; +C = 'S': use the square-root Singular Perturbation +C Approximation method; +C = 'P': use the balancing-free square-root +C Singular Perturbation Approximation method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C P <= M if BETA = 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order +C on entry, and NMIN is the order of a minimal realization +C of the ALPHA-stable part of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than NS*EPS, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than MAX(TOL1,NS*EPS); +C NR can be further reduced to ensure that +C HSV(NR-NU) > HSV(NR+1-NU). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C BETA (input) DOUBLE PRECISION +C BETA > 0 specifies the absolute/relative error weighting +C parameter. A large positive value of BETA favours the +C minimization of the absolute approximation error, while a +C small value of BETA is appropriate for the minimization +C of the relative error. +C BETA = 0 means a pure relative error method and can be +C used only if rank(D) = P. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues in an +C upper real Schur form. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the phase system corresponding +C to the ALPHA-stable part of the original system. +C The Hankel singular values are ordered decreasingly. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value of TOL1 lies +C in the interval [0.00001,0.001]. +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS, where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C TOL1 < 1. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the phase system (see METHOD) corresponding +C to the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C TOL2 < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains RCOND, the reciprocal +C condition number of the U11 matrix from the expression +C used to compute the solution X = U21*inv(U11) of the +C Riccati equation for spectral factorization. +C A small value RCOND indicates possible ill-conditioning +C of the respective Riccati equation. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*N*N + MB*(N+P) + MAX( 2, N*(MAX(N,MB,P)+5), +C 2*N*P+MAX(P*(MB+2),10*N*(N+1) ) ), +C where MB = M if BETA = 0 and MB = M+P if BETA > 0. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension 2*N +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system; in this case, the resulting NR is set equal +C to NSMIN; +C = 2: with ORDSEL = 'F', the selected order NR corresponds +C to repeated singular values for the ALPHA-stable +C part, which are neither all included nor all +C excluded from the reduced model; in this case, the +C resulting NR is automatically decreased to exclude +C all repeated singular values; +C = 3: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system; in this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the reduction of the Hamiltonian matrix to real +C Schur form failed; +C = 3: the reordering of the real Schur form of the +C Hamiltonian matrix failed; +C = 4: the Hamiltonian matrix has less than N stable +C eigenvalues; +C = 5: the coefficient matrix U11 in the linear system +C X*U11 = U21 to determine X is singular to working +C precision; +C = 6: BETA = 0 and D has not a maximal row rank; +C = 7: the computation of Hankel singular values failed; +C = 8: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 9: the resulting order of reduced stable part is less +C than the number of unstable zeros of the stable +C part. +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09HD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (2) +C +C such that +C +C INFNORM[inv(conj(W))*(G-Gr)] <= +C (1+HSV(NR+NS-N+1)) / (1-HSV(NR+NS-N+1)) + ... +C + (1+HSV(NS)) / (1-HSV(NS)) - 1, +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, W is the right, minimum +C phase spectral factor satisfying +C +C G1*conj(G1) = conj(W)* W, (3) +C +C G1 is the NS-order ALPHA-stable part of G, and INFNORM(G) is the +C infinity-norm of G. HSV(1), ... , HSV(NS) are the Hankel-singular +C values of the stable part of the phase system (Ap,Bp,Cp) +C with the transfer-function matrix +C +C P = inv(conj(W))*G1. +C +C If BETA > 0, then the model reduction is performed on [G BETA*I] +C instead of G. This is the recommended approach to be used when D +C has not a maximal row rank or when a certain balance between +C relative and absolute approximation errors is desired. For +C increasingly large values of BETA, the obtained reduced system +C assymptotically approaches that computed by using the +C Balance & Truncate or Singular Perturbation Approximation methods. +C +C Note: conj(G) denotes either G'(-s) for a continuous-time system +C or G'(1/z) for a discrete-time system. +C inv(G) is the inverse of G. +C +C The following procedure is used to reduce a given G: +C +C 1) Decompose additively G as +C +C G = G1 + G2, +C +C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. +C +C 2) Determine G1r, a reduced order approximation of the +C ALPHA-stable part G1 using the balancing stochastic method +C in conjunction with either the B&T [1,2] or SPA methods [3]. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C Note: The employed stochastic truncation algorithm [2,3] has the +C property that right half plane zeros of G1 remain as right half +C plane zeros of G1r. Thus, the order can not be chosen smaller than +C the sum of the number of unstable poles of G and the number of +C unstable zeros of G1. +C +C The reduction of the ALPHA-stable part G1 is done as follows. +C +C If JOB = 'B', the square-root stochastic Balance & Truncate +C method of [1] is used. +C For an ALPHA-stable continuous-time system (DICO = 'C'), +C the resulting reduced model is stochastically balanced. +C +C If JOB = 'F', the balancing-free square-root version of the +C stochastic Balance & Truncate method [1] is used to reduce +C the ALPHA-stable part G1. +C +C If JOB = 'S', the stochastic balancing method is used to reduce +C the ALPHA-stable part G1, in conjunction with the square-root +C version of the Singular Perturbation Approximation method [3,4]. +C +C If JOB = 'P', the stochastic balancing method is used to reduce +C the ALPHA-stable part G1, in conjunction with the balancing-free +C square-root version of the Singular Perturbation Approximation +C method [3,4]. +C +C REFERENCES +C +C [1] Varga A. and Fasol K.H. +C A new square-root balancing-free stochastic truncation model +C reduction algorithm. +C Proc. 12th IFAC World Congress, Sydney, 1993. +C +C [2] Safonov M. G. and Chiang R. Y. +C Model reduction for robust control: a Schur relative error +C method. +C Int. J. Adapt. Contr. Sign. Proc., vol. 2, pp. 259-272, 1988. +C +C [3] Green M. and Anderson B. D. O. +C Generalized balanced stochastic truncation. +C Proc. 29-th CDC, Honolulu, Hawaii, pp. 476-481, 1990. +C +C [4] Varga A. +C Balancing-free square-root algorithm for computing +C singular perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. The effectiveness of the +C accuracy enhancing technique depends on the accuracy of the +C solution of a Riccati equation. An ill-conditioned Riccati +C solution typically results when [D BETA*I] is nearly +C rank deficient. +C 3 +C The algorithm requires about 100N floating point operations. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Partly based on the RASP routine SRBFS, by A. Varga, 1992. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. +C Oct. 2001. +C +C KEYWORDS +C +C Minimal realization, model reduction, multivariable system, +C state-space model, state-space representation, +C stochastic balancing. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, TWOBY3, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ TWOBY3 = TWO/3.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, NS, P + DOUBLE PRECISION ALPHA, BETA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) + LOGICAL BWORK(*) +C .. Local Scalars .. + LOGICAL BTA, DISCR, FIXORD, LEQUIL, SPA + INTEGER IERR, IWARNL, KB, KD, KT, KTI, KU, KW, KWI, KWR, + $ LW, LWR, MB, N2, NMR, NN, NRA, NU, NU1, WRKOPT + DOUBLE PRECISION EPSM, MAXRED, RICOND, SCALEC, SCALEO +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB04MD, AB09HY, AB09IX, DLACPY, DLASET, TB01ID, + $ TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEQUIL = LSAME( EQUIL, 'S' ) + BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) + SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) + MB = M + IF( BETA.GT.ZERO ) MB = M + P + LW = 2*N*N + MB*(N+P) + MAX( 2, N*(MAX( N, MB, P )+5), + $ 2*N*P+MAX( P*(MB+2), 10*N*(N+1) ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 .OR. ( BETA.EQ.ZERO .AND. P.GT.M ) ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -9 + ELSE IF( BETA.LT.ZERO ) THEN + INFO = -10 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -18 + ELSE IF( TOL1.GE.ONE ) THEN + INFO = -21 + ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) + $ .OR. TOL2.GE.ONE ) THEN + INFO = -22 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09HD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. + $ ( BTA .AND. FIXORD .AND. NR.EQ.0 ) ) THEN + NR = 0 + NS = 0 + IWORK(1) = 0 + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C + IF( LEQUIL ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Allocate working storage. +C + NN = N*N + KU = 1 + KWR = KU + NN + KWI = KWR + N + KW = KWI + N + LWR = LDWORK - KW + 1 +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPHA, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LWR, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 8 + END IF + RETURN + END IF +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 3 + ELSE + NRA = 0 + END IF +C +C Finish if the system is completely unstable. +C + IF( NS.EQ.0 ) THEN + NR = NU + IWORK(1) = NS + DWORK(1) = WRKOPT + DWORK(2) = ONE + RETURN + END IF +C + NU1 = NU + 1 +C +C Allocate working storage. +C + N2 = N + N + KB = 1 + KD = KB + N*MB + KT = KD + P*MB + KTI = KT + N*N + KW = KTI + N*N +C +C Form [B 0] and [D BETA*I]. +C + CALL DLACPY( 'F', NS, M, B(NU1,1), LDB, DWORK(KB), N ) + CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) + IF( BETA.GT.ZERO ) THEN + CALL DLASET( 'F', NS, P, ZERO, ZERO, DWORK(KB+N*M), N ) + CALL DLASET( 'F', P, P, ZERO, BETA, DWORK(KD+P*M), P ) + END IF +C +C For discrete-time case, apply the discrete-to-continuous bilinear +C transformation to the stable part. +C + IF( DISCR ) THEN +C +C Real workspace: need N, prefer larger; +C Integer workspace: need N. +C + CALL AB04MD( 'Discrete', NS, MB, P, ONE, ONE, A(NU1,NU1), LDA, + $ DWORK(KB), N, C(1,NU1), LDC, DWORK(KD), P, + $ IWORK, DWORK(KT), LDWORK-KT+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KT) ) + KT - 1 ) + END IF +C +C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R +C of the controllability and observability Grammians, respectively. +C Real workspace: need 2*N*N + MB*(N+P)+ +C MAX( 2, N*(MAX(N,MB,P)+5), +C 2*N*P+MAX(P*(MB+2), 10*N*(N+1) ) ); +C prefer larger. +C Integer workspace: need 2*N. +C + CALL AB09HY( NS, MB, P, A(NU1,NU1), LDA, DWORK(KB), N, + $ C(1,NU1), LDC, DWORK(KD), P, SCALEC, SCALEO, + $ DWORK(KTI), N, DWORK(KT), N, IWORK, DWORK(KW), + $ LDWORK-KW+1, BWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + RICOND = DWORK(KW+1) +C +C Compute a BTA or SPA of the stable part. +C Real workspace: need 2*N*N + MB*(N+P)+ +C MAX( 1, 2*N*N+5*N, N*MAX(MB,P) ). +C + EPSM = DLAMCH( 'Epsilon' ) + CALL AB09IX( 'C', JOB, 'Schur', ORDSEL, NS, MB, P, NRA, SCALEC, + $ SCALEO, A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, + $ DWORK(KD), P, DWORK(KTI), N, DWORK(KT), N, NMR, HSV, + $ MAX( TOL1, N*EPSM ), TOL2, IWORK, DWORK(KW), + $ LDWORK-KW+1, IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN + INFO = 7 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Check if the resulting order is greater than the number of +C unstable zeros (this check is implicit by looking at Hankel +C singular values equal to 1). +C + IF( NRA.LT.NS .AND. HSV(NRA+1).GE.ONE-EPSM**TWOBY3 ) THEN + INFO = 9 + RETURN + END IF +C +C For discrete-time case, apply the continuous-to-discrete +C bilinear transformation. +C + IF( DISCR ) THEN + CALL AB04MD( 'Continuous', NRA, MB, P, ONE, ONE, + $ A(NU1,NU1), LDA, DWORK(KB), N, C(1,NU1), LDC, + $ DWORK(KD), P, IWORK, DWORK, LDWORK, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C + CALL DLACPY( 'F', NRA, M, DWORK(KB), N, B(NU1,1), LDB ) + CALL DLACPY( 'F', P, M, DWORK(KD), P, D, LDD ) +C + NR = NRA + NU +C + IWORK(1) = NMR + DWORK(1) = WRKOPT + DWORK(2) = RICOND +C + RETURN +C *** Last line of AB09HD *** + END diff --git a/mex/sources/libslicot/AB09HX.f b/mex/sources/libslicot/AB09HX.f new file mode 100644 index 000000000..4bba6fe3b --- /dev/null +++ b/mex/sources/libslicot/AB09HX.f @@ -0,0 +1,690 @@ + SUBROUTINE AB09HX( DICO, JOB, ORDSEL, N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, HSV, T, LDT, TI, LDTI, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, BWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C stable state-space representation (A,B,C,D) by using the +C stochastic balancing approach in conjunction with the square-root +C or the balancing-free square-root Balance & Truncate (B&T) or +C Singular Perturbation Approximation (SPA) model reduction methods. +C The state dynamics matrix A of the original system is an upper +C quasi-triangular matrix in real Schur canonical form and D must be +C full row rank. +C +C For the B&T approach, the matrices of the reduced order system +C are computed using the truncation formulas: +C +C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) +C +C For the SPA approach, the matrices of a minimal realization +C (Am,Bm,Cm) are computed using the truncation formulas: +C +C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) +C +C Am, Bm, Cm and D serve further for computing the SPA of the given +C system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'F': use the balancing-free square-root +C Balance & Truncate method; +C = 'S': use the square-root Singular Perturbation +C Approximation method; +C = 'P': use the balancing-free square-root +C Singular Perturbation Approximation method. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. M >= P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMIN), where NR +C is the desired order on entry and NMIN is the order of a +C minimal realization of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than N*EPS, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A in a real Schur +C canonical form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values, +C ordered decreasingly, of the phase system. All singular +C values are less than or equal to 1. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,N) +C If INFO = 0 and NR > 0, the leading N-by-NR part of this +C array contains the right truncation matrix T in (1), for +C the B&T approach, or in (2), for the SPA approach. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C TI (output) DOUBLE PRECISION array, dimension (LDTI,N) +C If INFO = 0 and NR > 0, the leading NR-by-N part of this +C array contains the left truncation matrix TI in (1), for +C the B&T approach, or in (2), for the SPA approach. +C +C LDTI INTEGER +C The leading dimension of array TI. LDTI >= MAX(1,N). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value lies in the +C interval [0.00001,0.001]. +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = N*EPS, where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the phase system (see METHOD) corresponding +C to the given system. +C The recommended value is TOL2 = N*EPS. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit with INFO = 0, IWORK(1) contains the order of the +C minimal realization of the system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains RCOND, the reciprocal +C condition number of the U11 matrix from the expression +C used to compute the solution X = U21*inv(U11) of the +C Riccati equation for spectral factorization. +C A small value RCOND indicates possible ill-conditioning +C of the respective Riccati equation. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), +C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension 2*N +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than the order of a minimal realization of the +C given system. In this case, the resulting NR is +C set automatically to a value corresponding to the +C order of a minimal realization of the system. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'), or it is not in +C a real Schur form; +C = 2: the reduction of Hamiltonian matrix to real +C Schur form failed; +C = 3: the reordering of the real Schur form of the +C Hamiltonian matrix failed; +C = 4: the Hamiltonian matrix has less than N stable +C eigenvalues; +C = 5: the coefficient matrix U11 in the linear system +C X*U11 = U21, used to determine X, is singular to +C working precision; +C = 6: the feedthrough matrix D has not a full row rank P; +C = 7: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (3) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09HX determines for +C the given system (3), the matrices of a reduced NR-rder system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (4) +C +C such that +C +C HSV(NR) <= INFNORM(G-Gr) <= 2*[HSV(NR+1) + ... + HSV(N)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C If JOB = 'B', the square-root stochastic Balance & Truncate +C method of [1] is used and the resulting model is balanced. +C +C If JOB = 'F', the balancing-free square-root version of the +C stochastic Balance & Truncate method [1] is used. +C +C If JOB = 'S', the stochastic balancing method, in conjunction +C with the square-root version of the Singular Perturbation +C Approximation method [2,3] is used. +C +C If JOB = 'P', the stochastic balancing method, in conjunction +C with the balancing-free square-root version of the Singular +C Perturbation Approximation method [2,3] is used. +C +C By setting TOL1 = TOL2, the routine can be also used to compute +C Balance & Truncate approximations. +C +C REFERENCES +C +C [1] Varga A. and Fasol K.H. +C A new square-root balancing-free stochastic truncation +C model reduction algorithm. +C Proc. of 12th IFAC World Congress, Sydney, 1993. +C +C [2] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of balanced systems. +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [3] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented method relies on accuracy enhancing square-root +C or balancing-free square-root methods. The effectiveness of the +C accuracy enhancing technique depends on the accuracy of the +C solution of a Riccati equation. Ill-conditioned Riccati solution +C typically results when D is nearly rank deficient. +C 3 +C The algorithm requires about 100N floating point operations. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Partly based on the RASP routine SRBFS1, by A. Varga, 1992. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. +C +C KEYWORDS +C +C Balance and truncate, minimal state-space representation, +C model reduction, multivariable system, +C singular perturbation approximation, state-space model, +C stochastic balancing. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, + $ LDWORK, M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) + LOGICAL BWORK(*) +C .. Local Scalars .. + LOGICAL BAL, BTA, DISCR, FIXORD, SPA + INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, + $ NMINR, NR1, NS, WRKOPT + DOUBLE PRECISION ATOL, RCOND, RICOND, SCALEC, SCALEO, TEMP, + $ TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB04MD, AB09DD, AB09HY, DGEMM, DGEMV, DGEQRF, + $ DGETRF, DGETRS, DLACPY, DORGQR, DSCAL, DTRMM, + $ DTRMV, MA02AD, MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) + SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) + BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LW = MAX( 2, N*(MAX( N, M, P )+5), + $ 2*N*P+MAX( P*(M+2), 10*N*(N+1) ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 .OR. P.GT.M ) THEN + INFO = -6 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -22 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09HX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C +C For discrete-time case, apply the discrete-to-continuous bilinear +C transformation. +C + IF( DISCR ) THEN +C +C Real workspace: need N, prefer larger; +C Integer workspace: need N. +C + CALL AB04MD( 'Discrete', N, M, P, ONE, ONE, A, LDA, B, LDB, + $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( N, INT( DWORK(1) ) ) + ELSE + WRKOPT = 0 + END IF +C +C Compute in TI and T the Cholesky factors Su and Ru of the +C controllability and observability Grammians, respectively. +C Real workspace: need MAX( 2, N*(MAX(N,M,P)+5), +C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ); +C prefer larger. +C Integer workspace: need 2*N. +C + CALL AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ SCALEC, SCALEO, TI, LDTI, T, LDT, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) + IF( INFO.NE.0) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + RICOND = DWORK(2) +C +C Save Su in V. +C + KU = 1 + KV = KU + N*N + KW = KV + N*N + CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) +C | x x | +C Compute Ru*Su in the form | 0 x | in TI. +C + DO 10 J = 1, N + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, + $ TI(1,J), 1 ) + 10 CONTINUE +C +C Compute the singular value decomposition Ru*Su = V*S*UT +C of the upper triangular matrix Ru*Su, with UT in TI and V in U. +C +C Workspace: need 2*N*N + 5*N; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 7 + RETURN + ENDIF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Scale the singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) +C +C Partition S, U and V conformally as: +C +C S = diag(S1,S2,S3), U = [U1,U2,U3] (U' in TI) and V = [V1,V2,V3] +C (in U). +C +C Compute the order NR of reduced system, as the order of S1. +C + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + ATOL = TOLDEF + IF( FIXORD ) THEN + IF( NR.GT.0 ) THEN + IF( HSV(NR).LE.ATOL ) THEN + NR = 0 + IWARN = 1 + FIXORD = .FALSE. + ENDIF + ENDIF + ELSE + ATOL = MAX( TOL1, ATOL ) + NR = 0 + ENDIF + IF( .NOT.FIXORD ) THEN + DO 20 J = 1, N + IF( HSV(J).LE.ATOL ) GO TO 30 + NR = NR + 1 + 20 CONTINUE + 30 CONTINUE + ENDIF +C +C Compute the order of minimal realization as the order of [S1 S2]. +C + NR1 = NR + 1 + NMINR = NR + IF( NR.LT.N ) THEN + IF( SPA ) ATOL = MAX( TOL2, TOLDEF ) + DO 40 J = NR1, N + IF( HSV(J).LE.ATOL ) GO TO 50 + NMINR = NMINR + 1 + 40 CONTINUE + 50 CONTINUE + END IF +C +C Finish if the order is zero. +C + IF( NR.EQ.0 ) THEN + IF( SPA ) THEN + CALL AB09DD( 'Continuous', N, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) + IWORK(1) = NMINR + ELSE + IWORK(1) = 0 + END IF + DWORK(1) = WRKOPT + DWORK(2) = RICOND + RETURN + END IF +C +C Compute NS, the order of S2. +C Note: For BTA, NS is always zero, because NMINR = NR. +C + NS = NMINR - NR +C +C Compute the truncation matrices. +C +C Compute TI' = | TI1' TI2' | = Ru'*| V1 V2 | in U. +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NMINR, + $ ONE, T, LDT, DWORK(KU), N ) +C +C Compute T = | T1 T2 | = Su*| U1 U2 | . +C + CALL MA02AD( 'Full', NMINR, N, TI, LDTI, T, LDT ) + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, + $ NMINR, ONE, DWORK(KV), N, T, LDT ) + KTAU = KV +C + IF( BAL ) THEN + IJ = KU +C +C Square-Root B&T/SPA method. +C +C Compute the truncation matrices for balancing +C -1/2 -1/2 +C T1*S1 and TI1'*S1 . +C + DO 70 J = 1, NR + TEMP = ONE/SQRT( HSV(J) ) + CALL DSCAL( N, TEMP, T(1,J), 1 ) + CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) + IJ = IJ + N + 70 CONTINUE + ELSE +C +C Balancing-Free B&T/SPA method. +C +C Compute orthogonal bases for the images of matrices T1 and +C TI1'. +C +C Workspace: need N*MAX(N,M,P) + 2*NR; +C prefer N*MAX(N,M,P) + NR*(NB+1) +C (NB determined by ILAENV for DGEQRF). +C + KW = KTAU + NR + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) + CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF + IF( NS.GT.0 ) THEN +C +C Compute orthogonal bases for the images of matrices T2 and +C TI2'. +C +C Workspace: need N*MAX(N,M,P) + 2*NS; +C prefer N*MAX(N,M,P) + NS*(NB+1) +C (NB determined by ILAENV for DGEQRF). + KW = KTAU + NS + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), + $ DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF +C +C Transpose TI' in TI. +C + CALL MA02AD( 'Full', N, NMINR, DWORK(KU), N, TI, LDTI ) +C + IF( .NOT.BAL ) THEN +C -1 +C Compute (TI1*T1) *TI1 in TI. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, + $ LDTI, T, LDT, ZERO, DWORK(KU), N ) + CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, + $ LDTI, IERR ) +C + IF( NS.GT.0 ) THEN +C -1 +C Compute (TI2*T2) *TI2 in TI2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, + $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), + $ N ) + CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, + $ TI(NR1,1), LDTI, IERR ) + END IF + END IF +C +C Compute TI*A*T (A is in RSF). +C + IJ = KU + DO 80 J = 1, N + K = MIN( J+1, N ) + CALL DGEMV( 'NoTranspose', NMINR, K, ONE, TI, LDTI, A(1,J), 1, + $ ZERO, DWORK(IJ), 1 ) + IJ = IJ + N + 80 CONTINUE + CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, NMINR, N, ONE, + $ DWORK(KU), N, T, LDT, ZERO, A, LDA ) +C +C Compute TI*B and C*T. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NMINR, M, N, ONE, TI, + $ LDTI, DWORK(KU), N, ZERO, B, LDB ) +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NMINR, N, ONE, + $ DWORK(KU), P, T, LDT, ZERO, C, LDC ) +C +C Compute the singular perturbation approximation if possible. +C Note that IERR = 1 on exit from AB09DD cannot appear here. +C +C Workspace: need real 4*(NMINR-NR); +C need integer 2*(NMINR-NR). +C + CALL AB09DD( 'Continuous', NMINR, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) +C +C For discrete-time case, apply the continuous-to-discrete +C bilinear transformation. +C + IF( DISCR ) THEN + CALL AB04MD( 'Continuous', NR, M, P, ONE, ONE, A, LDA, B, LDB, + $ C, LDC, D, LDD, IWORK, DWORK, LDWORK, IERR ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF + IWORK(1) = NMINR + DWORK(1) = WRKOPT + DWORK(2) = RICOND +C + RETURN +C *** Last line of AB09HX *** + END diff --git a/mex/sources/libslicot/AB09HY.f b/mex/sources/libslicot/AB09HY.f new file mode 100644 index 000000000..78a1093e6 --- /dev/null +++ b/mex/sources/libslicot/AB09HY.f @@ -0,0 +1,396 @@ + SUBROUTINE AB09HY( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ SCALEC, SCALEO, S, LDS, R, LDR, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factors Su and Ru of the controllability +C Grammian P = Su*Su' and observability Grammian Q = Ru'*Ru, +C respectively, satisfying +C +C A*P + P*A' + scalec^2*B*B' = 0, (1) +C +C A'*Q + Q*A + scaleo^2*Cw'*Cw = 0, (2) +C +C where +C Cw = Hw - Bw'*X, +C Hw = inv(Dw)*C, +C Bw = (B*D' + P*C')*inv(Dw'), +C D*D' = Dw*Dw' (Dw upper triangular), +C +C and, with Aw = A - Bw*Hw, X is the stabilizing solution of the +C Riccati equation +C +C Aw'*X + X*Aw + Hw'*Hw + X*Bw*Bw'*X = 0. (3) +C +C The P-by-M matrix D must have full row rank. Matrix A must be +C stable and in a real Schur form. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of state-space representation, i.e., +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. M >= P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C stable state dynamics matrix A in a real Schur canonical +C form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B, corresponding to the Schur matrix A. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C, corresponding to the Schur +C matrix A. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must +C contain the full row rank input/output matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C SCALEC (output) DOUBLE PRECISION +C Scaling factor for the controllability Grammian in (1). +C +C SCALEO (output) DOUBLE PRECISION +C Scaling factor for the observability Grammian in (2). +C +C S (output) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor Su of the cotrollability +C Grammian P = Su*Su' satisfying (1). +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor Ru of the observability +C Grammian Q = Ru'*Ru satisfying (2). +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C Workspace +C +C IWORK INTEGER array, dimension 2*N +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains RCOND, the reciprocal +C condition number of the U11 matrix from the expression +C used to compute X = U21*inv(U11). A small value RCOND +C indicates possible ill-conditioning of the Riccati +C equation (3). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 2, N*(MAX(N,M,P)+5), +C 2*N*P+MAX(P*(M+2),10*N*(N+1) ) ). +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension 2*N +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable or is not in a +C real Schur form; +C = 2: the reduction of Hamiltonian matrix to real Schur +C form failed; +C = 3: the reordering of the real Schur form of the +C Hamiltonian matrix failed; +C = 4: the Hamiltonian matrix has less than N stable +C eigenvalues; +C = 5: the coefficient matrix U11 in the linear system +C X*U11 = U21, used to determine X, is singular to +C working precision; +C = 6: the feedthrough matrix D has not a full row rank P. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Based on the RASP routines SRGRO and SRGRO1, by A. Varga, 1992. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. +C +C KEYWORDS +C +C Minimal realization, model reduction, multivariable system, +C state-space model, state-space representation, +C stochastic balancing. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDR, LDS, LDWORK, M, N, + $ P + DOUBLE PRECISION SCALEC, SCALEO +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), R(LDR,*), S(LDS,*) + LOGICAL BWORK(*) +C .. Local Scalars .. + INTEGER I, IERR, KBW, KCW, KD, KDW, KG, KQ, KS, KTAU, KU, + $ KW, KWI, KWR, LW, N2, WRKOPT + DOUBLE PRECISION RCOND, RTOL +C .. External Functions .. + DOUBLE PRECISION DLANGE, DLAMCH + EXTERNAL DLANGE, DLAMCH +C .. External Subroutines .. + EXTERNAL DGEMM, DGERQF, DLACPY, DORGRQ, DSYRK, DTRMM, + $ DTRSM, SB02MD, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LW = MAX( 2, N*( MAX( N, M, P ) + 5 ), + $ 2*N*P + MAX( P*(M + 2), 10*N*(N + 1) ) ) +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 .OR. P.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09HY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALEC = ONE + SCALEO = ONE + IF( MIN( N, M, P ).EQ.0 ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C +C Solve for Su the Lyapunov equation +C 2 +C A*(Su*Su') + (Su*Su')*A' + scalec *B*B' = 0 . +C +C Workspace: need N*(MAX(N,M) + 5); +C prefer larger. +C + KU = 1 + KTAU = KU + N*MAX( N, M ) + KW = KTAU + N +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL SB03OU( .FALSE., .TRUE., N, M, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), + $ LDWORK - KW + 1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Allocate workspace for Bw' (P*N), Cw (P*N), Q2 (P*M), +C where Q2 = inv(Dw)*D. +C Workspace: need 2*N*P + P*M. +C + KBW = 1 + KCW = KBW + P*N + KD = KCW + P*N + KDW = KD + P*(M - P) + KTAU = KD + P*M + KW = KTAU + P +C +C Compute an upper-triangular Dw such that D*D' = Dw*Dw', using +C the RQ-decomposition of D: D = [0 Dw]*( Q1 ). +C ( Q2 ) +C Additional workspace: need 2*P; prefer P + P*NB. +C + CALL DLACPY( 'F', P, M, D, LDD, DWORK(KD), P ) + CALL DGERQF( P, M, DWORK(KD), P, DWORK(KTAU), DWORK(KW), + $ LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Check the full row rank of D. +C + RTOL = DBLE( M ) * DLAMCH( 'E' ) * + $ DLANGE( '1', P, M, D, LDD, DWORK ) + DO 10 I = KDW, KDW+P*P-1, P+1 + IF( ABS( DWORK(I) ).LE.RTOL ) THEN + INFO = 6 + RETURN + END IF + 10 CONTINUE +C -1 +C Compute Hw = Dw *C. +C + CALL DLACPY( 'F', P, N, C, LDC, DWORK(KCW), P ) + CALL DTRSM( 'Left', 'Upper', 'No-transpose', 'Non-unit', P, N, + $ ONE, DWORK(KDW), P, DWORK(KCW), P ) +C +C Compute Bw' = inv(Dw)*(D*B' + C*Su*Su'). +C +C Compute first Hw*Su*Su' in Bw'. +C + CALL DLACPY( 'F', P, N, DWORK(KCW), P, DWORK(KBW), P ) + CALL DTRMM( 'Right', 'Upper', 'No-transpose', 'Non-unit', P, N, + $ ONE, S, LDS, DWORK(KBW), P ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', P, N, + $ ONE, S, LDS, DWORK(KBW), P ) +C +C Compute Q2 = inv(Dw)*D, as the last P lines of the orthogonal +C matrix ( Q1 ) from the RQ decomposition of D. +C ( Q2 ) +C Additional workspace: need P; prefer P*NB. +C + CALL DORGRQ( P, M, P, DWORK(KD), P, DWORK(KTAU), DWORK(KW), + $ LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute Bw' <- Bw' + Q2*B'. +C + CALL DGEMM( 'No-transpose', 'Transpose', P, N, M, ONE, + $ DWORK(KD), P, B, LDB, ONE, DWORK(KBW), P ) +C +C Compute Aw = A - Bw*Hw in R. +C + CALL DLACPY( 'F', N, N, A, LDA, R, LDR ) + CALL DGEMM( 'Transpose', 'No-transpose', N, N, P, -ONE, + $ DWORK(KBW), P, DWORK(KCW), P, ONE, R, LDR ) +C +C Allocate storage to solve the Riccati equation (3) for +C G(N*N), Q(N*N), WR(2N), WI(2N), S(2N*2N), U(2N*2N). +C + N2 = N + N + KG = KD + KQ = KG + N*N + KWR = KQ + N*N + KWI = KWR + N2 + KS = KWI + N2 + KU = KS + N2*N2 + KW = KU + N2*N2 +C +C Compute G = -Bw*Bw'. +C + CALL DSYRK( 'Upper', 'Transpose', N, P, -ONE, DWORK(KBW), P, ZERO, + $ DWORK(KG), N ) +C +C Compute Q = Hw'*Hw. +C + CALL DSYRK( 'Upper', 'Transpose', N, P, ONE, DWORK(KCW), P, ZERO, + $ DWORK(KQ), N ) +C +C Solve +C +C Aw'*X + X*Aw + Q - X*G*X = 0, +C +C with Q = Hw'*Hw and G = -Bw*Bw'. +C Additional workspace: need 6*N; +C prefer larger. +C + CALL SB02MD( 'Continuous', 'None', 'Upper', 'General', 'Stable', + $ N, R, LDR, DWORK(KG), N, DWORK(KQ), N, RCOND, + $ DWORK(KWR), DWORK(KWI), DWORK(KS), N2, + $ DWORK(KU), N2, IWORK, DWORK(KW), LDWORK-KW+1, + $ BWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute Cw = Hw - Bw'*X. +C + CALL DGEMM ( 'No-transpose', 'No-transpose', P, N, N, -ONE, + $ DWORK(KBW), P, DWORK(KQ), N, ONE, DWORK(KCW), P ) +C +C Solve for Ru the Lyapunov equation +C 2 +C A'*(Ru'*Ru) + (Ru'*Ru)*A + scaleo * Cw'*Cw = 0 . +C +C Workspace: need N*(MAX(N,P) + 5); +C prefer larger. +C + KTAU = KCW + N*MAX( N, P ) + KW = KTAU + N +C + CALL SB03OU( .FALSE., .FALSE., N, P, A, LDA, DWORK(KCW), P, + $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), + $ LDWORK - KW + 1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Save optimal workspace and RCOND. +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of AB09HY *** + END diff --git a/mex/sources/libslicot/AB09ID.f b/mex/sources/libslicot/AB09ID.f new file mode 100644 index 000000000..2448d4660 --- /dev/null +++ b/mex/sources/libslicot/AB09ID.f @@ -0,0 +1,1048 @@ + SUBROUTINE AB09ID( DICO, JOBC, JOBO, JOB, WEIGHT, EQUIL, ORDSEL, + $ N, M, P, NV, PV, NW, MW, NR, ALPHA, ALPHAC, + $ ALPHAO, A, LDA, B, LDB, C, LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the frequency +C weighted square-root or balancing-free square-root +C Balance & Truncate (B&T) or Singular Perturbation Approximation +C (SPA) model reduction methods. The algorithm tries to minimize +C the norm of the frequency-weighted error +C +C ||V*(G-Gr)*W|| +C +C where G and Gr are the transfer-function matrices of the original +C and reduced order models, respectively, and V and W are +C frequency-weighting transfer-function matrices. V and W must not +C have poles on the imaginary axis for a continuous-time +C system or on the unit circle for a discrete-time system. +C If G is unstable, only the ALPHA-stable part of G is reduced. +C In case of possible pole-zero cancellations in V*G and/or G*W, +C the absolute values of parameters ALPHAO and/or ALPHAC must be +C different from 1. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBC CHARACTER*1 +C Specifies the choice of frequency-weighted controllability +C Grammian as follows: +C = 'S': choice corresponding to a combination method [4] +C of the approaches of Enns [1] and Lin-Chiu [2,3]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [4]. +C +C JOBO CHARACTER*1 +C Specifies the choice of frequency-weighted observability +C Grammian as follows: +C = 'S': choice corresponding to a combination method [4] +C of the approaches of Enns [1] and Lin-Chiu [2,3]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [4]. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'F': use the balancing-free square-root +C Balance & Truncate method; +C = 'S': use the square-root Singular Perturbation +C Approximation method; +C = 'P': use the balancing-free square-root +C Singular Perturbation Approximation method. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'L': only left weighting V is used (W = I); +C = 'R': only right weighting W is used (V = I); +C = 'B': both left and right weightings V and W are used. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NV (input) INTEGER +C The order of the matrix AV. Also the number of rows of +C the matrix BV and the number of columns of the matrix CV. +C NV represents the dimension of the state vector of the +C system with the transfer-function matrix V. NV >= 0. +C +C PV (input) INTEGER +C The number of rows of the matrices CV and DV. PV >= 0. +C PV represents the dimension of the output vector of the +C system with the transfer-function matrix V. +C +C NW (input) INTEGER +C The order of the matrix AW. Also the number of rows of +C the matrix BW and the number of columns of the matrix CW. +C NW represents the dimension of the state vector of the +C system with the transfer-function matrix W. NW >= 0. +C +C MW (input) INTEGER +C The number of columns of the matrices BW and DW. MW >= 0. +C MW represents the dimension of the input vector of the +C system with the transfer-function matrix W. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order +C on entry, NMIN is the number of frequency-weighted Hankel +C singular values greater than NS*EPS*S1, EPS is the +C machine precision (see LAPACK Library Routine DLAMCH) +C and S1 is the largest Hankel singular value (computed +C in HSV(1)); NR can be further reduced to ensure +C HSV(NR-NU) > HSV(NR+1-NU); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than MAX(TOL1,NS*EPS*S1). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C ALPHAC (input) DOUBLE PRECISION +C Combination method parameter for defining the +C frequency-weighted controllability Grammian (see METHOD); +C ABS(ALPHAC) <= 1. +C +C ALPHAO (input) DOUBLE PRECISION +C Combination method parameter for defining the +C frequency-weighted observability Grammian (see METHOD); +C ABS(ALPHAO) <= 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV +C part of this array must contain the state matrix AV of +C the system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading NVR-by-NVR part of this array +C contains the state matrix of a minimal realization of V +C in a real Schur form. NVR is returned in IWORK(2). +C AV is not referenced if WEIGHT = 'R' or 'N', +C or MIN(N,M,P) = 0. +C +C LDAV INTEGER +C The leading dimension of array AV. +C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDAV >= 1, if WEIGHT = 'R' or 'N'. +C +C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part +C of this array must contain the input matrix BV of the +C system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading NVR-by-P part of this array contains +C the input matrix of a minimal realization of V. +C BV is not referenced if WEIGHT = 'R' or 'N', +C or MIN(N,M,P) = 0. +C +C LDBV INTEGER +C The leading dimension of array BV. +C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDBV >= 1, if WEIGHT = 'R' or 'N'. +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading PV-by-NV +C part of this array must contain the output matrix CV of +C the system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading PV-by-NVR part of this array +C contains the output matrix of a minimal realization of V. +C CV is not referenced if WEIGHT = 'R' or 'N', +C or MIN(N,M,P) = 0. +C +C LDCV INTEGER +C The leading dimension of array CV. +C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; +C LDCV >= 1, if WEIGHT = 'R' or 'N'. +C +C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) +C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this +C array must contain the feedthrough matrix DV of the system +C with the transfer-function matrix V. +C DV is not referenced if WEIGHT = 'R' or 'N', +C or MIN(N,M,P) = 0. +C +C LDDV INTEGER +C The leading dimension of array DV. +C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; +C LDDV >= 1, if WEIGHT = 'R' or 'N'. +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW +C part of this array must contain the state matrix AW of +C the system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading NWR-by-NWR part of this array +C contains the state matrix of a minimal realization of W +C in a real Schur form. NWR is returned in IWORK(3). +C AW is not referenced if WEIGHT = 'L' or 'N', +C or MIN(N,M,P) = 0. +C +C LDAW INTEGER +C The leading dimension of array AW. +C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDAW >= 1, if WEIGHT = 'L' or 'N'. +C +C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,MW) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-MW +C part of this array must contain the input matrix BW of the +C system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading NWR-by-MW part of this array +C contains the input matrix of a minimal realization of W. +C BW is not referenced if WEIGHT = 'L' or 'N', +C or MIN(N,M,P) = 0. +C +C LDBW INTEGER +C The leading dimension of array BW. +C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDBW >= 1, if WEIGHT = 'L' or 'N'. +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part +C of this array must contain the output matrix CW of the +C system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', MIN(N,M,P) > 0 and +C INFO = 0, the leading M-by-NWR part of this array contains +C the output matrix of a minimal realization of W. +C CW is not referenced if WEIGHT = 'L' or 'N', +C or MIN(N,M,P) = 0. +C +C LDCW INTEGER +C The leading dimension of array CW. +C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDCW >= 1, if WEIGHT = 'L' or 'N'. +C +C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) +C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this +C array must contain the feedthrough matrix DW of the system +C with the transfer-function matrix W. +C DW is not referenced if WEIGHT = 'L' or 'N', +C or MIN(N,M,P) = 0. +C +C LDDW INTEGER +C The leading dimension of array DW. +C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDDW >= 1, if WEIGHT = 'L' or 'N'. +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of this array contain +C the frequency-weighted Hankel singular values, ordered +C decreasingly, of the ALPHA-stable part of the original +C system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*S1, where c is a constant in the +C interval [0.00001,0.001], and S1 is the largest +C frequency-weighted Hankel singular value of the +C ALPHA-stable part of the original system (computed +C in HSV(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*S1, where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*S1. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension +C ( MAX( 3, LIWRK1, LIWRK2, LIWRK3 ) ), where +C LIWRK1 = 0, if JOB = 'B'; +C LIWRK1 = N, if JOB = 'F'; +C LIWRK1 = 2*N, if JOB = 'S' or 'P'; +C LIWRK2 = 0, if WEIGHT = 'R' or 'N' or NV = 0; +C LIWRK2 = NV+MAX(P,PV), if WEIGHT = 'L' or 'B' and NV > 0; +C LIWRK3 = 0, if WEIGHT = 'L' or 'N' or NW = 0; +C LIWRK3 = NW+MAX(M,MW), if WEIGHT = 'R' or 'B' and NW > 0. +C On exit, if INFO = 0, IWORK(1) contains the order of a +C minimal realization of the stable part of the system, +C IWORK(2) and IWORK(3) contain the actual orders +C of the state space realizations of V and W, respectively. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LMINL, LMINR, LRCF, +C 2*N*N + MAX( 1, LLEFT, LRIGHT, 2*N*N+5*N, +C N*MAX(M,P) ) ), +C where +C LMINL = 0, if WEIGHT = 'R' or 'N' or NV = 0; otherwise, +C LMINL = MAX(LLCF,NV+MAX(NV,3*P)) if P = PV; +C LMINL = MAX(P,PV)*(2*NV+MAX(P,PV))+ +C MAX(LLCF,NV+MAX(NV,3*P,3*PV)) if P <> PV; +C LRCF = 0, and +C LMINR = 0, if WEIGHT = 'L' or 'N' or NW = 0; otherwise, +C LMINR = NW+MAX(NW,3*M) if M = MW; +C LMINR = 2*NW*MAX(M,MW)+NW+MAX(NW,3*M,3*MW) if M <> MW; +C LLCF = PV*(NV+PV)+PV*NV+MAX(NV*(NV+5), PV*(PV+2), +C 4*PV, 4*P); +C LRCF = MW*(NW+MW)+MAX(NW*(NW+5),MW*(MW+2),4*MW,4*M) +C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) +C if WEIGHT = 'L' or 'B' and PV > 0; +C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; +C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) +C if WEIGHT = 'R' or 'B' and MW > 0; +C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system; in this case, the resulting NR is set equal +C to NSMIN; +C = 2: with ORDSEL = 'F', the selected order NR corresponds +C to repeated singular values for the ALPHA-stable +C part, which are neither all included nor all +C excluded from the reduced model; in this case, the +C resulting NR is automatically decreased to exclude +C all repeated singular values; +C = 3: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system; in this case NR is set equal to the +C order of the ALPHA-unstable part. +C = 10+K: K violations of the numerical stability condition +C occured during the assignment of eigenvalues in the +C SLICOT Library routines SB08CD and/or SB08DD. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable +C diagonal blocks failed because of very close +C eigenvalues; +C = 3: the reduction to a real Schur form of the state +C matrix of a minimal realization of V failed; +C = 4: a failure was detected during the ordering of the +C real Schur form of the state matrix of a minimal +C realization of V or in the iterative process to +C compute a left coprime factorization with inner +C denominator; +C = 5: if DICO = 'C' and the matrix AV has an observable +C eigenvalue on the imaginary axis, or DICO = 'D' and +C AV has an observable eigenvalue on the unit circle; +C = 6: the reduction to a real Schur form of the state +C matrix of a minimal realization of W failed; +C = 7: a failure was detected during the ordering of the +C real Schur form of the state matrix of a minimal +C realization of W or in the iterative process to +C compute a right coprime factorization with inner +C denominator; +C = 8: if DICO = 'C' and the matrix AW has a controllable +C eigenvalue on the imaginary axis, or DICO = 'D' and +C AW has a controllable eigenvalue on the unit circle; +C = 9: the computation of eigenvalues failed; +C = 10: the computation of Hankel singular values failed. +C +C METHOD +C +C Let G be the transfer-function matrix of the original +C linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09ID determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (2) +C +C such that the corresponding transfer-function matrix Gr minimizes +C the norm of the frequency-weighted error +C +C V*(G-Gr)*W, (3) +C +C where V and W are transfer-function matrices without poles on the +C imaginary axis in continuous-time case or on the unit circle in +C discrete-time case. +C +C The following procedure is used to reduce G: +C +C 1) Decompose additively G, of order N, as +C +C G = G1 + G2, +C +C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and +C G2 = (A2,B2,C2,0), of order NU, has only ALPHA-unstable poles. +C +C 2) Compute for G1 a B&T or SPA frequency-weighted approximation +C G1r of order NR-NU using the combination method or the +C modified combination method of [4]. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C For the frequency-weighted reduction of the ALPHA-stable part, +C several methods described in [4] can be employed in conjunction +C with the combination method and modified combination method +C proposed in [4]. +C +C If JOB = 'B', the square-root B&T method is used. +C If JOB = 'F', the balancing-free square-root version of the +C B&T method is used. +C If JOB = 'S', the square-root version of the SPA method is used. +C If JOB = 'P', the balancing-free square-root version of the +C SPA method is used. +C +C For each of these methods, left and right truncation matrices +C are determined using the Cholesky factors of an input +C frequency-weighted controllability Grammian P and an output +C frequency-weighted observability Grammian Q. +C P and Q are computed from the controllability Grammian Pi of G*W +C and the observability Grammian Qo of V*G. Using special +C realizations of G*W and V*G, Pi and Qo are computed in the +C partitioned forms +C +C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , +C ( P12' P22 ) ( Q12' Q22 ) +C +C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, +C respectively. Let P0 and Q0 be non-negative definite matrices +C defined below +C -1 +C P0 = P11 - ALPHAC**2*P12*P22 *P21 , +C -1 +C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. +C +C The frequency-weighted controllability and observability +C Grammians, P and Q, respectively, are defined as follows: +C P = P0 if JOBC = 'S' (standard combination method [4]); +C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability +C Grammian defined to enforce stability for a modified combination +C method of [4]; +C Q = Q0 if JOBO = 'S' (standard combination method [4]); +C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability +C Grammian defined to enforce stability for a modified combination +C method of [4]. +C +C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of +C Grammians corresponds to the method of Enns [1], while if +C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds +C to the method of Lin and Chiu [2,3]. +C +C If JOBC = 'S' and ALPHAC = 1, no pole-zero cancellations must +C occur in G*W. If JOBO = 'S' and ALPHAO = 1, no pole-zero +C cancellations must occur in V*G. The presence of pole-zero +C cancellations leads to meaningless results and must be avoided. +C +C The frequency-weighted Hankel singular values HSV(1), ...., +C HSV(N) are computed as the square roots of the eigenvalues +C of the product P*Q. +C +C REFERENCES +C +C [1] Enns, D. +C Model reduction with balanced realizations: An error bound +C and a frequency weighted generalization. +C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. +C +C [2] Lin, C.-A. and Chiu, T.-Y. +C Model reduction via frequency-weighted balanced realization. +C Control Theory and Advanced Technology, vol. 8, +C pp. 341-351, 1992. +C +C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. +C New results on frequency weighted balanced reduction +C technique. +C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. +C +C [4] Varga, A. and Anderson, B.D.O. +C Square-root balancing-free methods for the frequency-weighted +C balancing related model reduction. +C (report in preparation) +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root +C techniques. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. +C D. Sima, University of Bucharest, August 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Sep. 2001. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, JOBC, JOBO, ORDSEL, WEIGHT + INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, MW, + $ N, NR, NS, NV, NW, P, PV + DOUBLE PRECISION ALPHA, ALPHAC, ALPHAO, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), + $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), + $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), + $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), + $ HSV(*) +C .. Local Scalars .. + LOGICAL BAL, BTA, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW, + $ SCALE, SPA + INTEGER IERR, IWARNL, KBR, KBV, KBW, KCR, KCV, KCW, KDR, + $ KDV, KI, KL, KT, KTI, KU, KW, LCF, LDW, LW, NMR, + $ NN, NNQ, NNR, NNV, NNW, NRA, NU, NU1, NVR, NWR, + $ PPV, WRKOPT + DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09IX, AB09IY, DLACPY, SB08CD, SB08DD, TB01ID, + $ TB01KD, TB01PD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) + SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) + BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) + SCALE = LSAME( EQUIL, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) + RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) + FRWGHT = LEFTW .OR. RIGHTW +C + LW = 1 + NN = N*N + NNV = N + NV + NNW = N + NW + PPV = MAX( P, PV ) +C + IF( LEFTW .AND. PV.GT.0 ) THEN + LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) + ELSE + LW = MAX( LW, N*( P + 5 ) ) + END IF +C + IF( RIGHTW .AND. MW.GT.0 ) THEN + LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) + ELSE + LW = MAX( LW, N*( M + 5 ) ) + END IF + LW = 2*NN + MAX( LW, 2*NN + 5*N, N*MAX( M, P ) ) +C + IF( LEFTW .AND. NV.GT.0 ) THEN + LCF = PV*( NV + PV ) + PV*NV + + $ MAX( NV*( NV + 5 ), PV*( PV + 2 ), 4*PPV ) + IF( PV.EQ.P ) THEN + LW = MAX( LW, LCF, NV + MAX( NV, 3*P ) ) + ELSE + LW = MAX( LW, PPV*( 2*NV + PPV ) + + $ MAX( LCF, NV + MAX( NV, 3*PPV ) ) ) + END IF + END IF +C + IF( RIGHTW .AND. NW.GT.0 ) THEN + IF( MW.EQ.M ) THEN + LW = MAX( LW, NW + MAX( NW, 3*M ) ) + ELSE + LW = MAX( LW, 2*NW*MAX( M, MW ) + + $ NW + MAX( NW, 3*M, 3*MW ) ) + END IF + LW = MAX( LW, MW*( NW + MW ) + + $ MAX( NW*( NW + 5 ), MW*( MW + 2 ), 4*MW, 4*M ) ) + END IF +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( SCALE .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -6 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( NV.LT.0 ) THEN + INFO = -11 + ELSE IF( PV.LT.0 ) THEN + INFO = -12 + ELSE IF( NW.LT.0 ) THEN + INFO = -13 + ELSE IF( MW.LT.0 ) THEN + INFO = -14 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -15 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -16 + ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN + INFO = -17 + ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN + INFO = -18 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -24 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -26 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -28 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -30 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN + INFO = -32 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN + INFO = -34 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -36 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -38 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -40 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -42 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -46 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -49 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09ID', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NS = 0 + IWORK(1) = 0 + IWORK(2) = NV + IWORK(3) = NW + DWORK(1) = ONE + RETURN + END IF +C + IF( SCALE ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + KU = 1 + KL = KU + NN + KI = KL + N + KW = KI + N +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation, A <- inv(T)*A*T, and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), + $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Determine NRA, the desired order for the reduction of stable part. +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 3 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + DWORK(1) = WRKOPT + IWORK(1) = 0 + IWORK(2) = NV + IWORK(3) = NW + RETURN + END IF +C + NVR = NV + IF( LEFTW .AND. NV.GT.0 ) THEN +C +C Compute a left-coprime factorization with inner denominator +C of a minimal realization of V. The resulting AV is in +C real Schur form. +C Workspace needed: real LV+MAX( 1, LCF, +C NV + MAX( NV, 3*P, 3*PV ) ), +C where +C LV = 0 if P = PV and +C LV = MAX(P,PV)*(2*NV+MAX(P,PV)) +C otherwise; +C LCF = PV*(NV+PV) + +C MAX( 1, PV*NV + MAX( NV*(NV+5), +C PV*(PV+2),4*PV,4*P ) ); +C prefer larger; +C integer NV + MAX(P,PV). +C + IF( P.EQ.PV ) THEN + KW = 1 + CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, + $ BV, LDBV, CV, LDCV, NVR, ZERO, + $ IWORK, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + KBR = 1 + KDR = KBR + PV*NVR + KW = KDR + PV*PV + CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, + $ DV, LDDV, NNQ, NNR, DWORK(KBR), MAX( 1, NVR ), + $ DWORK(KDR), PV, ZERO, DWORK(KW), LDWORK-KW+1, + $ IWARN, IERR ) + ELSE + LDW = MAX( P, PV ) + KBV = 1 + KCV = KBV + NV*LDW + KW = KCV + NV*LDW + CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KBV), NV ) + CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KCV), LDW ) + CALL TB01PD( 'Minimal', 'Scale', NV, P, PV, AV, LDAV, + $ DWORK(KBV), NV, DWORK(KCV), LDW, NVR, ZERO, + $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) + KDV = KW + KBR = KDV + LDW*LDW + KDR = KBR + PV*NVR + KW = KDR + PV*PV + CALL DLACPY( 'Full', PV, P, DV, LDDV, DWORK(KDV), LDW ) + CALL SB08CD( DICO, NVR, P, PV, AV, LDAV, DWORK(KBV), NV, + $ DWORK(KCV), LDW, DWORK(KDV), LDW, NNQ, NNR, + $ DWORK(KBR), MAX( 1, NVR ), DWORK(KDR), PV, + $ ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + CALL DLACPY( 'Full', NVR, P, DWORK(KBV), NV, BV, LDBV ) + CALL DLACPY( 'Full', PV, NVR, DWORK(KCV), LDW, CV, LDCV ) + CALL DLACPY( 'Full', PV, P, DWORK(KDV), LDW, DV, LDDV ) + END IF + IF( IERR.NE.0 ) THEN + INFO = IERR + 2 + RETURN + END IF + NVR = NNQ + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + IF( IWARN.GT.0 ) + $ IWARN = 10 + IWARN + END IF +C + NWR = NW + IF( RIGHTW .AND. NW.GT.0 ) THEN +C +C Compute a minimal realization of W. +C Workspace needed: real LW+MAX(1, NW + MAX(NW, 3*M, 3*MW)); +C where +C LW = 0, if M = MW and +C LW = 2*NW*MAX(M,MW), otherwise; +C prefer larger; +C integer NW + MAX(M,MW). +C + IF( M.EQ.MW ) THEN + KW = 1 + CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, + $ BW, LDBW, CW, LDCW, NWR, ZERO, IWORK, DWORK, + $ LDWORK, INFO ) + ELSE + LDW = MAX( M, MW ) + KBW = 1 + KCW = KBW + NW*LDW + KW = KCW + NW*LDW + CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KBW), NW ) + CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KCW), LDW ) + CALL TB01PD( 'Minimal', 'Scale', NW, MW, M, AW, LDAW, + $ DWORK(KBW), NW, DWORK(KCW), LDW, NWR, ZERO, + $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) + CALL DLACPY( 'Full', NWR, MW, DWORK(KBW), NW, BW, LDBW ) + CALL DLACPY( 'Full', M, NWR, DWORK(KCW), LDW, CW, LDCW ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C + IF( RIGHTW .AND. NWR.GT.0 ) THEN +C +C Compute a right-coprime factorization with inner denominator +C of the minimal realization of W. The resulting AW is in +C real Schur form. +C +C Workspace needed: MW*(NW+MW) + +C MAX( 1, NW*(NW+5), MW*(MW+2), 4*MW, 4*M ); +C prefer larger. +C + LDW = MAX( 1, MW ) + KCR = 1 + KDR = KCR + NWR*LDW + KW = KDR + MW*LDW + CALL SB08DD( DICO, NWR, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, + $ DW, LDDW, NNQ, NNR, DWORK(KCR), LDW, DWORK(KDR), + $ LDW, ZERO, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + IF( IERR.NE.0 ) THEN + INFO = IERR + 5 + RETURN + END IF + NWR = NNQ + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + IF( IWARN.GT.0 ) + $ IWARN = 10 + IWARN + END IF +C + NU1 = NU + 1 +C +C Allocate working storage. +C + KT = 1 + KTI = KT + NN + KW = KTI + NN +C +C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R +C of the controllability and observability Grammians, respectively. +C Real workspace: need 2*N*N + MAX( 1, LLEFT, LRIGHT ), +C where +C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) +C if WEIGHT = 'L' or 'B' and PV > 0; +C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; +C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) +C if WEIGHT = 'R' or 'B' and MW > 0; +C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. +C prefer larger. +C + CALL AB09IY( DICO, JOBC, JOBO, WEIGHT, NS, M, P, NVR, PV, NWR, + $ MW, ALPHAC, ALPHAO, A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, AV, LDAV, BV, LDBV, CV, LDCV, + $ DV, LDDV, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ SCALEC, SCALEO, DWORK(KTI), N, DWORK(KT), N, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 9 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute a BTA or SPA of the stable part. +C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ). +C + CALL AB09IX( DICO, JOB, 'Schur', ORDSEL, NS, M, P, NRA, + $ SCALEC, SCALEO, A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KTI), N, DWORK(KT), N, + $ NMR, HSV, TOL1, TOL2, IWORK, DWORK(KW), LDWORK-KW+1, + $ IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN + INFO = 10 + RETURN + END IF + NR = NRA + NU +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + IWORK(1) = NMR + IWORK(2) = NVR + IWORK(3) = NWR +C + RETURN +C *** Last line of AB09ID *** + END diff --git a/mex/sources/libslicot/AB09IX.f b/mex/sources/libslicot/AB09IX.f new file mode 100644 index 000000000..f3ad3b395 --- /dev/null +++ b/mex/sources/libslicot/AB09IX.f @@ -0,0 +1,695 @@ + SUBROUTINE AB09IX( DICO, JOB, FACT, ORDSEL, N, M, P, NR, + $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, + $ TI, LDTI, T, LDT, NMINR, HSV, TOL1, TOL2, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the square-root or +C balancing-free square-root Balance & Truncate (B&T) or +C Singular Perturbation Approximation (SPA) model reduction methods. +C The computation of truncation matrices TI and T is based on +C the Cholesky factor S of a controllability Grammian P = S*S' +C and the Cholesky factor R of an observability Grammian Q = R'*R, +C where S and R are given upper triangular matrices. +C +C For the B&T approach, the matrices of the reduced order system +C are computed using the truncation formulas: +C +C Ar = TI * A * T , Br = TI * B , Cr = C * T . (1) +C +C For the SPA approach, the matrices of a minimal realization +C (Am,Bm,Cm) are computed using the truncation formulas: +C +C Am = TI * A * T , Bm = TI * B , Cm = C * T . (2) +C +C Am, Bm, Cm and D serve further for computing the SPA of the given +C system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root B&T method; +C = 'F': use the balancing-free square-root B&T method; +C = 'S': use the square-root SPA method; +C = 'P': use the balancing-free square-root SPA method. +C +C FACT CHARACTER*1 +C Specifies whether or not, on entry, the matrix A is in a +C real Schur form, as follows: +C = 'S': A is in a real Schur form; +C = 'N': A is a general dense square matrix. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. NR is set as follows: +C if ORDSEL = 'F', NR is equal to MIN(NR,NMINR), where NR +C is the desired order on entry and NMINR is the number of +C the Hankel singular values greater than N*EPS*S1, where +C EPS is the machine precision (see LAPACK Library Routine +C DLAMCH) and S1 is the largest Hankel singular value +C (computed in HSV(1)); +C NR can be further reduced to ensure HSV(NR) > HSV(NR+1); +C if ORDSEL = 'A', NR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*S1). +C +C SCALEC (input) DOUBLE PRECISION +C Scaling factor for the Cholesky factor S of the +C controllability Grammian, i.e., S/SCALEC is used to +C compute the Hankel singular values. SCALEC > 0. +C +C SCALEO (input) DOUBLE PRECISION +C Scaling factor for the Cholesky factor R of the +C observability Grammian, i.e., R/SCALEO is used to +C compute the Hankel singular values. SCALEO > 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. If FACT = 'S', +C A is in a real Schur form. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, if JOB = 'S' or JOB = 'P', the leading P-by-M +C part of this array must contain the original input/output +C matrix D. +C On exit, if INFO = 0 and JOB = 'S' or JOB = 'P', the +C leading P-by-M part of this array contains the +C input/output matrix Dr of the reduced order system. +C If JOB = 'B' or JOB = 'F', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= 1, if JOB = 'B' or JOB = 'F'; +C LDD >= MAX(1,P), if JOB = 'S' or JOB = 'P'. +C +C TI (input/output) DOUBLE PRECISION array, dimension (LDTI,N) +C On entry, the leading N-by-N upper triangular part of +C this array must contain the Cholesky factor S of a +C controllability Grammian P = S*S'. +C On exit, if INFO = 0, and NR > 0, the leading NMINR-by-N +C part of this array contains the left truncation matrix +C TI in (1), for the B&T approach, or in (2), for the +C SPA approach. +C +C LDTI INTEGER +C The leading dimension of array TI. LDTI >= MAX(1,N). +C +C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) +C On entry, the leading N-by-N upper triangular part of +C this array must contain the Cholesky factor R of an +C observability Grammian Q = R'*R. +C On exit, if INFO = 0, and NR > 0, the leading N-by-NMINR +C part of this array contains the right truncation matrix +C T in (1), for the B&T approach, or in (2), for the +C SPA approach. +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C NMINR (output) INTEGER +C The number of Hankel singular values greater than +C MAX(TOL2,N*EPS*S1). +C Note: If S and R are the Cholesky factors of the +C controllability and observability Grammians of the +C original system (A,B,C,D), respectively, then NMINR is +C the order of a minimal realization of the original system. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the Hankel singular values, +C ordered decreasingly. The Hankel singular values are +C singular values of the product R*S. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of the reduced system. +C For model reduction, the recommended value lies in the +C interval [0.00001,0.001]. +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = N*EPS*S1, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH) and S1 is the largest +C Hankel singular value (computed in HSV(1)). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the system. +C The recommended value is TOL2 = N*EPS*S1. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0, and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension LIWORK, where +C LIWORK = 0, if JOB = 'B'; +C LIWORK = N, if JOB = 'F'; +C LIWORK = 2*N, if JOB = 'S' or 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, 2*N*N + 5*N, N*MAX(M,P) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NMINR, the order of a minimal realization of +C the given system; in this case, the resulting NR is +C set automatically to NMINR; +C = 2: with ORDSEL = 'F', the selected order NR corresponds +C to repeated singular values, which are neither all +C included nor all excluded from the reduced model; +C in this case, the resulting NR is set automatically +C to the largest value such that HSV(NR) > HSV(NR+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (3) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09IX determines for +C the given system (3), the matrices of a reduced NR order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (4) +C +C by using the square-root or balancing-free square-root +C Balance & Truncate (B&T) or Singular Perturbation Approximation +C (SPA) model reduction methods. +C +C The projection matrices TI and T are determined using the +C Cholesky factors S and R of a controllability Grammian P and an +C observability Grammian Q. +C The Hankel singular values HSV(1), ...., HSV(N) are computed as +C singular values of the product R*S. +C +C If JOB = 'B', the square-root Balance & Truncate technique +C of [1] is used. +C +C If JOB = 'F', the balancing-free square-root version of the +C Balance & Truncate technique [2] is used. +C +C If JOB = 'S', the square-root version of the Singular Perturbation +C Approximation method [3,4] is used. +C +C If JOB = 'P', the balancing-free square-root version of the +C Singular Perturbation Approximation method [3,4] is used. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudni, P. Borne, S. G. Tzafestas (Eds.), +C Vol. 2, pp. 42-46. +C +C [3] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of balanced systems. +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [4] Varga A. +C Balancing-free square-root algorithm for computing singular +C perturbation approximations. +C Proc. 30-th CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented method relies on accuracy enhancing square-root +C or balancing-free square-root methods. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. +C D. Sima, University of Bucharest, August 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Sep. 2001. +C +C KEYWORDS +C +C Balance and truncate, minimal state-space representation, +C model reduction, multivariable system, +C singular perturbation approximation, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDT, LDTI, + $ LDWORK, M, N, NMINR, NR, P + DOUBLE PRECISION SCALEC, SCALEO, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*), T(LDT,*), TI(LDTI,*) +C .. Local Scalars .. + LOGICAL BAL, BTA, DISCR, FIXORD, RSF, SPA + INTEGER IERR, IJ, J, K, KTAU, KU, KV, KW, LDW, LW, + $ NRED, NR1, NS, WRKOPT + DOUBLE PRECISION ATOL, RCOND, SKP, TEMP, TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09DD, DGEMM, DGEMV, DGEQRF, DGETRF, DGETRS, + $ DLACPY, DORGQR, DSCAL, DTRMM, DTRMV, MA02AD, + $ MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BTA = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'F' ) + SPA = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'P' ) + BAL = LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'S' ) + RSF = LSAME( FACT, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C + LW = MAX( 1, 2*N*N + 5*N, N*MAX( M, P ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( RSF .OR. LSAME( FACT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( SCALEC.LE.ZERO ) THEN + INFO = -9 + ELSE IF( SCALEO.LE.ZERO ) THEN + INFO = -10 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( SPA .AND. LDD.LT.P ) ) THEN + INFO = -18 + ELSE IF( LDTI.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -26 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -29 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09IX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NMINR = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Save S in DWORK(KV). +C + KV = 1 + KU = KV + N*N + KW = KU + N*N + CALL DLACPY( 'Upper', N, N, TI, LDTI, DWORK(KV), N ) +C | x x | +C Compute R*S in the form | 0 x | in TI. +C + DO 10 J = 1, N + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', J, T, LDT, + $ TI(1,J), 1 ) + 10 CONTINUE +C +C Compute the singular value decomposition R*S = V*Sigma*UT of the +C upper triangular matrix R*S, with UT in TI and V in DWORK(KU). +C +C Workspace: need 2*N*N + 5*N; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', N, TI, LDTI, DWORK(KU), N, HSV, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Scale the singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) +C +C Partition Sigma, U and V conformally as: +C +C Sigma = diag(Sigma1,Sigma2,Sigma3), U = [U1,U2,U3] (U' in TI) and +C V = [V1,V2,V3] (in DWORK(KU)). +C +C Compute NMINR, the order of a minimal realization, as the order +C of [Sigma1 Sigma2]. +C + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + ATOL = MAX( TOL2, TOLDEF*HSV(1) ) + NMINR = N + 20 IF( NMINR.GT.0 ) THEN + IF( HSV(NMINR).LE.ATOL ) THEN + NMINR = NMINR - 1 + GO TO 20 + END IF + END IF +C +C Compute the order NR of reduced system, as the order of Sigma1. +C + IF( FIXORD ) THEN +C +C Check if the desired order is less than the order of a minimal +C realization. +C + IF( NR.GT.NMINR ) THEN +C +C Reduce the order to NMINR. +C + NR = NMINR + IWARN = 1 + END IF +C +C Check for singular value multiplicity at cut-off point. +C + IF( NR.GT.0 .AND. NR.LT.NMINR ) THEN + SKP = HSV(NR) + IF( SKP-HSV(NR+1).LE.TOLDEF*SKP ) THEN + IWARN = 2 +C +C Reduce the order such that HSV(NR) > HSV(NR+1). +C + 30 NR = NR - 1 + IF( NR.GT.0 ) THEN + IF( HSV(NR)-SKP.LE.TOLDEF*SKP ) GO TO 30 + END IF + END IF + END IF + ELSE +C +C The order is given as the number of singular values +C exceeding MAX( TOL1, N*EPS*HSV(1) ). +C + ATOL = MAX( TOL1, ATOL ) + NR = 0 + DO 40 J = 1, NMINR + IF( HSV(J).LE.ATOL ) GO TO 50 + NR = NR + 1 + 40 CONTINUE + 50 CONTINUE + ENDIF +C +C Finish if the order is zero. +C + IF( NR.EQ.0 ) THEN + IF( SPA ) + $ CALL AB09DD( DICO, N, M, P, NR, A, LDA, B, LDB, C, LDC, + $ D, LDD, RCOND, IWORK, DWORK, IERR ) + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute NS, the order of Sigma2. For BTA, NS = 0. +C + IF( SPA ) THEN + NRED = NMINR + ELSE + NRED = NR + END IF + NS = NRED - NR +C +C Compute the truncation matrices. +C +C Compute TI' = | TI1' TI2' | = R'*| V1 V2 | in DWORK(KU). +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'NonUnit', N, NRED, + $ ONE, T, LDT, DWORK(KU), N ) +C +C Compute T = | T1 T2 | = S*| U1 U2 | . +C + CALL MA02AD( 'Full', NRED, N, TI, LDTI, T, LDT ) + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, + $ NRED, ONE, DWORK(KV), N, T, LDT ) +C + KTAU = KW + IF( BAL ) THEN + IJ = KU +C +C Square-Root B&T/SPA method. +C +C Compute the truncation matrices for balancing +C -1/2 -1/2 +C T1*Sigma1 and TI1'*Sigma1 . +C + DO 60 J = 1, NR + TEMP = ONE/SQRT( HSV(J) ) + CALL DSCAL( N, TEMP, T(1,J), 1 ) + CALL DSCAL( N, TEMP, DWORK(IJ), 1 ) + IJ = IJ + N + 60 CONTINUE +C + ELSE +C +C Balancing-Free B&T/SPA method. +C +C Compute orthogonal bases for the images of matrices T1 and +C TI1'. +C +C Workspace: need 2*N*N + 2*N; +C prefer larger. +C + KW = KTAU + NR + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, IERR ) + CALL DORGQR( N, NR, NR, T, LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DGEQRF( N, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NR, NR, DWORK(KU), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF +C + IF( NS.GT.0 ) THEN +C +C Compute orthogonal bases for the images of matrices T2 and +C TI2'. +C +C Workspace: need 2*N*N + 2*N; +C prefer larger. +C + NR1 = NR + 1 + KW = KTAU + NS + LDW = LDWORK - KW + 1 + CALL DGEQRF( N, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), LDW, + $ IERR ) + CALL DORGQR( N, NS, NS, T(1,NR1), LDT, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + CALL DGEQRF( N, NS, DWORK(KU+N*NR), N, DWORK(KTAU), DWORK(KW), + $ LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DORGQR( N, NS, NS, DWORK(KU+N*NR), N, DWORK(KTAU), + $ DWORK(KW), LDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + ENDIF +C +C Transpose TI' in TI. +C + CALL MA02AD( 'Full', N, NRED, DWORK(KU), N, TI, LDTI ) +C + IF( .NOT.BAL ) THEN +C -1 +C Compute (TI1*T1) *TI1 in TI. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NR, NR, N, ONE, TI, + $ LDTI, T, LDT, ZERO, DWORK(KU), N ) + CALL DGETRF( NR, NR, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NR, N, DWORK(KU), N, IWORK, TI, + $ LDTI, IERR ) +C + IF( NS.GT.0 ) THEN +C -1 +C Compute (TI2*T2) *TI2 in TI2. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NS, NS, N, ONE, + $ TI(NR1,1), LDTI, T(1,NR1), LDT, ZERO, DWORK(KU), + $ N ) + CALL DGETRF( NS, NS, DWORK(KU), N, IWORK, IERR ) + CALL DGETRS( 'NoTranspose', NS, N, DWORK(KU), N, IWORK, + $ TI(NR1,1), LDTI, IERR ) + END IF + END IF +C +C Compute TI*A*T. Exploit RSF of A if possible. +C Workspace: need N*N. +C + IF( RSF ) THEN + IJ = 1 + DO 80 J = 1, N + K = MIN( J+1, N ) + CALL DGEMV( 'NoTranspose', NRED, K, ONE, TI, LDTI, + $ A(1,J), 1, ZERO, DWORK(IJ), 1 ) + IJ = IJ + N + 80 CONTINUE + ELSE + CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, N, N, ONE, + $ TI, LDTI, A, LDA, ZERO, DWORK, N ) + END IF + CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, NRED, N, ONE, + $ DWORK, N, T, LDT, ZERO, A, LDA ) +C +C Compute TI*B and C*T. +C Workspace: need N*MAX(M,P). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NRED, M, N, ONE, TI, + $ LDTI, DWORK, N, ZERO, B, LDB ) +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NRED, N, ONE, + $ DWORK, P, T, LDT, ZERO, C, LDC ) +C +C Compute the singular perturbation approximation if possible. +C Note that IERR = 1 on exit from AB09DD cannot appear here. +C +C Workspace: need real 4*(NMINR-NR); +C need integer 2*(NMINR-NR). +C + IF( SPA) THEN + CALL AB09DD( DICO, NRED, M, P, NR, A, LDA, B, LDB, + $ C, LDC, D, LDD, RCOND, IWORK, DWORK, IERR ) + ELSE + NMINR = NR + END IF + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09IX *** + END diff --git a/mex/sources/libslicot/AB09IY.f b/mex/sources/libslicot/AB09IY.f new file mode 100644 index 000000000..475505219 --- /dev/null +++ b/mex/sources/libslicot/AB09IY.f @@ -0,0 +1,859 @@ + SUBROUTINE AB09IY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NV, PV, + $ NW, MW, ALPHAC, ALPHAO, A, LDA, B, LDB, C, LDC, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ SCALEC, SCALEO, S, LDS, R, LDR, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for given state-space representations +C (A,B,C,0), (AV,BV,CV,DV), and (AW,BW,CW,DW) of the +C transfer-function matrices G, V and W, respectively, +C the Cholesky factors of the frequency-weighted +C controllability and observability Grammians corresponding +C to a frequency-weighted model reduction problem. +C G, V and W must be stable transfer-function matrices with +C the state matrices A, AV, and AW in real Schur form. +C It is assumed that the state space realizations (AV,BV,CV,DV) +C and (AW,BW,CW,DW) are minimal. In case of possible pole-zero +C cancellations in forming V*G and/or G*W, the parameters for the +C choice of frequency-weighted Grammians ALPHAO and/or ALPHAC, +C respectively, must be different from 1. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G, V and W are continuous-time systems; +C = 'D': G, V and W are discrete-time systems. +C +C JOBC CHARACTER*1 +C Specifies the choice of frequency-weighted controllability +C Grammian as follows: +C = 'S': choice corresponding to a combination method [4] +C of the approaches of Enns [1] and Lin-Chiu [2,3]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [4]. +C +C JOBO CHARACTER*1 +C Specifies the choice of frequency-weighted observability +C Grammian as follows: +C = 'S': choice corresponding to a combination method [4] +C of the approaches of Enns [1] and Lin-Chiu [2,3]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [4]. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'L': only left weighting V is used (W = I); +C = 'R': only right weighting W is used (V = I); +C = 'B': both left and right weightings V and W are used. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation of G, i.e., +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix B and +C the number of rows of the matrices CW and DW. M >= 0. +C M represents the dimension of the input vector of the +C system with the transfer-function matrix G and +C also the dimension of the output vector of the system +C with the transfer-function matrix W. +C +C P (input) INTEGER +C The number of rows of the matrix C and the +C number of columns of the matrices BV and DV. P >= 0. +C P represents the dimension of the output vector of the +C system with the transfer-function matrix G and +C also the dimension of the input vector of the system +C with the transfer-function matrix V. +C +C NV (input) INTEGER +C The order of the matrix AV. Also the number of rows of +C the matrix BV and the number of columns of the matrix CV. +C NV represents the dimension of the state vector of the +C system with the transfer-function matrix V. NV >= 0. +C +C PV (input) INTEGER +C The number of rows of the matrices CV and DV. PV >= 0. +C PV represents the dimension of the output vector of the +C system with the transfer-function matrix V. +C +C NW (input) INTEGER +C The order of the matrix AW. Also the number of rows of +C the matrix BW and the number of columns of the matrix CW. +C NW represents the dimension of the state vector of the +C system with the transfer-function matrix W. NW >= 0. +C +C MW (input) INTEGER +C The number of columns of the matrices BW and DW. MW >= 0. +C MW represents the dimension of the input vector of the +C system with the transfer-function matrix W. +C +C ALPHAC (input) DOUBLE PRECISION +C Combination method parameter for defining the +C frequency-weighted controllability Grammian (see METHOD); +C ABS(ALPHAC) <= 1. +C +C ALPHAO (input) DOUBLE PRECISION +C Combination method parameter for defining the +C frequency-weighted observability Grammian (see METHOD); +C ABS(ALPHAO) <= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must +C contain the state matrix A (of the system with the +C transfer-function matrix G) in a real Schur form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C AV (input) DOUBLE PRECISION array, dimension (LDAV,NV) +C If WEIGHT = 'L' or 'B', the leading NV-by-NV part of this +C array must contain the state matrix AV (of the system with +C the transfer-function matrix V) in a real Schur form. +C AV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDAV INTEGER +C The leading dimension of array AV. +C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDAV >= 1, if WEIGHT = 'R' or 'N'. +C +C BV (input) DOUBLE PRECISION array, dimension (LDBV,P) +C If WEIGHT = 'L' or 'B', the leading NV-by-P part of this +C array must contain the input matrix BV of the system with +C the transfer-function matrix V. +C BV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDBV INTEGER +C The leading dimension of array BV. +C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDBV >= 1, if WEIGHT = 'R' or 'N'. +C +C CV (input) DOUBLE PRECISION array, dimension (LDCV,NV) +C If WEIGHT = 'L' or 'B', the leading PV-by-NV part of this +C array must contain the output matrix CV of the system with +C the transfer-function matrix V. +C CV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDCV INTEGER +C The leading dimension of array CV. +C LDCV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; +C LDCV >= 1, if WEIGHT = 'R' or 'N'. +C +C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) +C If WEIGHT = 'L' or 'B', the leading PV-by-P part of this +C array must contain the feedthrough matrix DV of the system +C with the transfer-function matrix V. +C DV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDDV INTEGER +C The leading dimension of array DV. +C LDDV >= MAX(1,PV), if WEIGHT = 'L' or 'B'; +C LDDV >= 1, if WEIGHT = 'R' or 'N'. +C +C AW (input) DOUBLE PRECISION array, dimension (LDAW,NW) +C If WEIGHT = 'R' or 'B', the leading NW-by-NW part of this +C array must contain the state matrix AW (of the system with +C the transfer-function matrix W) in a real Schur form. +C AW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDAW INTEGER +C The leading dimension of array AW. +C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDAW >= 1, if WEIGHT = 'L' or 'N'. +C +C BW (input) DOUBLE PRECISION array, dimension (LDBW,MW) +C If WEIGHT = 'R' or 'B', the leading NW-by-MW part of this +C array must contain the input matrix BW of the system with +C the transfer-function matrix W. +C BW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDBW INTEGER +C The leading dimension of array BW. +C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDBW >= 1, if WEIGHT = 'L' or 'N'. +C +C CW (input) DOUBLE PRECISION array, dimension (LDCW,NW) +C If WEIGHT = 'R' or 'B', the leading M-by-NW part of this +C array must contain the output matrix CW of the system with +C the transfer-function matrix W. +C CW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDCW INTEGER +C The leading dimension of array CW. +C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDCW >= 1, if WEIGHT = 'L' or 'N'. +C +C DW (input) DOUBLE PRECISION array, dimension (LDDW,MW) +C If WEIGHT = 'R' or 'B', the leading M-by-MW part of this +C array must contain the feedthrough matrix DW of the system +C with the transfer-function matrix W. +C DW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDDW INTEGER +C The leading dimension of array DW. +C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDDW >= 1, if WEIGHT = 'L' or 'N'. +C +C SCALEC (output) DOUBLE PRECISION +C Scaling factor for the controllability Grammian in (1) +C or (3). See METHOD. +C +C SCALEO (output) DOUBLE PRECISION +C Scaling factor for the observability Grammian in (2) +C or (4). See METHOD. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor S of the frequency-weighted +C cotrollability Grammian P = S*S'. See METHOD. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor R of the frequency-weighted +C observability Grammian Q = R'*R. See METHOD. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, LLEFT, LRIGHT ), +C where +C LLEFT = (N+NV)*(N+NV+MAX(N+NV,PV)+5) +C if WEIGHT = 'L' or 'B' and PV > 0; +C LLEFT = N*(P+5) if WEIGHT = 'R' or 'N' or PV = 0; +C LRIGHT = (N+NW)*(N+NW+MAX(N+NW,MW)+5) +C if WEIGHT = 'R' or 'B' and MW > 0; +C LRIGHT = N*(M+5) if WEIGHT = 'L' or 'N' or MW = 0. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the state matrices A and/or AV are not stable or +C not in a real Schur form; +C = 2: if the state matrices A and/or AW are not stable or +C not in a real Schur form; +C = 3: eigenvalues computation failure. +C +C METHOD +C +C Let Pi = Si*Si' and Qo = Ro'*Ro be the Cholesky factored +C controllability and observability Grammians satisfying +C in the continuous-time case +C +C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, (1) +C +C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, (2) +C +C and in the discrete-time case +C +C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, (3) +C +C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, (4) +C +C where +C +C Ai = ( A B*Cw ) , Bi = ( B*Dw ) , +C ( 0 Aw ) ( Bw ) +C +C Ao = ( A 0 ) , Co = ( Dv*C Cv ) . +C ( Bv*C Av ) +C +C Consider the partitioned Grammians +C +C Pi = ( P11 P12 ) and Qo = ( Q11 Q12 ) , +C ( P12' P22 ) ( Q12' Q22 ) +C +C where P11 and Q11 are the leading N-by-N parts of Pi and Qo, +C respectively, and let P0 and Q0 be non-negative definite matrices +C defined in the combination method [4] +C -1 +C P0 = P11 - ALPHAC**2*P12*P22 *P21 , +C -1 +C Q0 = Q11 - ALPHAO**2*Q12*Q22 *Q21. +C +C The frequency-weighted controllability and observability +C Grammians, P and Q, respectively, are defined as follows: +C P = P0 if JOBC = 'S' (standard combination method [4]); +C P = P1 >= P0 if JOBC = 'E', where P1 is the controllability +C Grammian defined to enforce stability for a modified combination +C method of [4]; +C Q = Q0 if JOBO = 'S' (standard combination method [4]); +C Q = Q1 >= Q0 if JOBO = 'E', where Q1 is the observability +C Grammian defined to enforce stability for a modified combination +C method of [4]. +C +C If JOBC = JOBO = 'S' and ALPHAC = ALPHAO = 0, the choice of +C Grammians corresponds to the method of Enns [1], while if +C ALPHAC = ALPHAO = 1, the choice of Grammians corresponds to the +C method of Lin and Chiu [2,3]. +C +C The routine computes directly the Cholesky factors S and R +C such that P = S*S' and Q = R'*R according to formulas +C developed in [4]. No matrix inversions are involved. +C +C REFERENCES +C +C [1] Enns, D. +C Model reduction with balanced realizations: An error bound +C and a frequency weighted generalization. +C Proc. CDC, Las Vegas, pp. 127-132, 1984. +C +C [2] Lin, C.-A. and Chiu, T.-Y. +C Model reduction via frequency-weighted balanced realization. +C Control Theory and Advanced Technology, vol. 8, +C pp. 341-351, 1992. +C +C [3] Sreeram, V., Anderson, B.D.O and Madievski, A.G. +C New results on frequency weighted balanced reduction +C technique. +C Proc. ACC, Seattle, Washington, pp. 4004-4009, 1995. +C +C [4] Varga, A. and Anderson, B.D.O. +C Square-root balancing-free methods for the frequency-weighted +C balancing related model reduction. +C (report in preparation) +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. +C D. Sima, University of Bucharest, August 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2001. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBC, JOBO, WEIGHT + INTEGER INFO, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDDV, LDDW, LDR, LDS, LDWORK, + $ M, MW, N, NV, NW, P, PV + DOUBLE PRECISION ALPHAC, ALPHAO, SCALEC, SCALEO +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), + $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), + $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), + $ DV(LDDV,*), DW(LDDW,*), + $ DWORK(*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL DISCR, FRWGHT, LEFTW, RIGHTW + INTEGER I, IERR, J, KAW, KTAU, KU, KW, LDU, LW, MBBAR, + $ NNV, NNW, PCBAR + DOUBLE PRECISION T, TOL, WORK +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLASET, DSCAL, DSYEV, + $ MB01WD, MB04ND, MB04OD, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) + RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) + FRWGHT = LEFTW .OR. RIGHTW +C + INFO = 0 + LW = 1 + NNV = N + NV + NNW = N + NW + IF( LEFTW .AND. PV.GT.0 ) THEN + LW = MAX( LW, NNV*( NNV + MAX( NNV, PV ) + 5 ) ) + ELSE + LW = MAX( LW, N*( P + 5 ) ) + END IF + IF( RIGHTW .AND. MW.GT.0 ) THEN + LW = MAX( LW, NNW*( NNW + MAX( NNW, MW ) + 5 ) ) + ELSE + LW = MAX( LW, N*( M + 5 ) ) + END IF +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( NV.LT.0 ) THEN + INFO = -8 + ELSE IF( PV.LT.0 ) THEN + INFO = -9 + ELSE IF( NW.LT.0 ) THEN + INFO = -10 + ELSE IF( MW.LT.0 ) THEN + INFO = -11 + ELSE IF( ABS( ALPHAC ).GT.ONE ) THEN + INFO = -12 + ELSE IF( ABS( ALPHAO ).GT.ONE ) THEN + INFO = -13 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -21 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -23 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.PV ) ) THEN + INFO = -25 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.PV ) ) THEN + INFO = -27 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -29 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -31 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -33 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -35 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -39 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -41 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -43 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09IY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALEC = ONE + SCALEO = ONE + IF( MIN( N, M, P ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + WORK = 1 + IF( LEFTW .AND. PV.GT.0 ) THEN +C +C Build the extended permuted matrices +C +C Ao = ( Av Bv*C ) , Co = ( Cv Dv*C ) . +C ( 0 A ) +C + KAW = 1 + KU = KAW + NNV*NNV + LDU = MAX( NNV, PV ) + CALL DLACPY( 'Full', NV, NV, AV, LDAV, DWORK(KAW), NNV ) + CALL DLASET( 'Full', N, NV, ZERO, ZERO, DWORK(KAW+NV), NNV ) + CALL DGEMM( 'No-transpose', 'No-transpose', NV, N, P, ONE, + $ BV, LDBV, C, LDC, ZERO, DWORK(KAW+NNV*NV), NNV ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW+NNV*NV+NV), NNV ) +C + CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KU), LDU ) + CALL DGEMM( 'No-transpose', 'No-transpose', PV, N, P, ONE, + $ DV, LDDV, C, LDC, ZERO, DWORK(KU+LDU*NV), LDU ) +C +C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. +C +C Workspace: need (N+NV)*(N+NV+MAX(N+NV,PV)+5); +C prefer larger. +C + KTAU = KU + LDU*NNV + KW = KTAU + NNV +C + CALL SB03OU( DISCR, .FALSE., NNV, PV, DWORK(KAW), NNV, + $ DWORK(KU), LDU, DWORK(KTAU), DWORK(KU), LDU, + $ SCALEO, DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Partition Ro as Ro = ( R11 R12 ) and compute R such that +C ( 0 R22 ) +C +C R'*R = R22'*R22 + (1-ALPHAO**2)*R12'*R12. +C + KW = KU + LDU*NV + NV + CALL DLACPY( 'Upper', N, N, DWORK(KW), LDU, R, LDR ) + IF( ALPHAO.NE.ZERO ) THEN + T = SQRT( ONE - ALPHAO*ALPHAO ) + DO 10 J = KU + LDU*NV, KU + LDU*(NNV-1), LDU + CALL DSCAL( NV, T, DWORK(J), 1 ) + 10 CONTINUE + END IF + IF( ALPHAO.LT.ONE .AND. NV.GT.0 ) THEN + KTAU = 1 + CALL MB04OD( 'Full', N, 0, NV, R, LDR, DWORK(KU+LDU*NV), + $ LDU, DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) +C + DO 30 J = 1, N + DWORK(J) = R(J,J) + DO 20 I = 1, J + IF ( DWORK(I).LT.ZERO ) R(I,J) = -R(I,J) + 20 CONTINUE + 30 CONTINUE +C + END IF +C + IF( LSAME( JOBO, 'E' ) .AND. ALPHAO.LT.ONE ) THEN +C +C Form Y = -A'*(R'*R)-(R'*R)*A if DICO = 'C', or +C Y = -A'*(R'*R)*A+(R'*R) if DICO = 'D'. +C + CALL DLACPY( 'Upper', N, N, R, LDR, DWORK(KU), N ) + CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', N, + $ -ONE, ZERO, R, LDR, DWORK(KAW+NNV*NV+NV), NNV, + $ DWORK(KU), N, IERR ) +C +C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. +C + KU = N + 1 + CALL DSYEV( 'Vectors', 'Upper', N, R, LDR, DWORK, DWORK(KU), + $ LDWORK-N, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) +C +C Partition Sigma = (Sigma1,Sigma2), such that +C Sigma1 <= 0, Sigma2 > 0. +C Partition correspondingly Z = [Z1 Z2]. +C + TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) + $ * DLAMCH( 'Epsilon') +C _ +C Form C = [ sqrt(Sigma2)*Z2' ] +C + PCBAR = 0 + DO 40 J = 1, N + IF( DWORK(J).GT.TOL ) THEN + CALL DSCAL( N, SQRT( DWORK(J) ), R(1,J), 1 ) + CALL DCOPY( N, R(1,J), 1, DWORK(KU+PCBAR), N ) + PCBAR = PCBAR + 1 + END IF + 40 CONTINUE +C +C Solve for the Cholesky factor R of Q, Q = R'*R, +C the continuous-time Lyapunov equation (if DICO = 'C') +C _ _ +C A'*Q + Q*A + t^2*C'*C = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C _ _ +C A'*Q*A - Q + t^2*C'*C = 0. +C +C Workspace: need N*(N + 6); +C prefer larger. +C + KTAU = KU + N*N + KW = KTAU + N +C + CALL SB03OU( DISCR, .FALSE., N, PCBAR, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), R, LDR, T, DWORK(KW), LDWORK-KW+1, + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + SCALEO = SCALEO*T + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) + END IF +C + ELSE +C +C Solve for the Cholesky factor R of Q, Q = R'*R, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C A'*Q + Q*A + scaleo^2*C'*C = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C A'*Q*A - Q + scaleo^2*C'*C = 0. +C +C Workspace: need N*(P + 5); +C prefer larger. +C + KU = 1 + KTAU = KU + P*N + KW = KTAU + N +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), P ) + CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), P, + $ DWORK(KTAU), R, LDR, SCALEO, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) + END IF +C + IF( RIGHTW .AND. MW.GT.0 ) THEN +C +C Build the extended matrices +C +C Ai = ( A B*Cw ) , Bi = ( B*Dw ) . +C ( 0 Aw ) ( Bw ) +C + KAW = 1 + KU = KAW + NNW*NNW + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), NNW ) + CALL DLASET( 'Full', NW, N, ZERO, ZERO, DWORK(KAW+N), NNW ) + CALL DGEMM( 'No-transpose', 'No-transpose', N, NW, M, ONE, + $ B, LDB, CW, LDCW, ZERO, DWORK(KAW+NNW*N), NNW ) + CALL DLACPY( 'Full', NW, NW, AW, LDAW, + $ DWORK(KAW+NNW*N+N), NNW ) +C + CALL DGEMM( 'No-transpose', 'No-transpose', N, MW, M, ONE, + $ B, LDB, DW, LDDW, ZERO, DWORK(KU), NNW ) + CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KU+N), NNW ) +C +C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. +C +C Workspace: need (N+NW)*(N+NW+MAX(N+NW,MW)+5); +C prefer larger. +C + KTAU = KU + NNW*MAX( NNW, MW ) + KW = KTAU + NNW +C + CALL SB03OU( DISCR, .TRUE., NNW, MW, DWORK(KAW), NNW, + $ DWORK(KU), NNW, DWORK(KTAU), DWORK(KU), NNW, + $ SCALEC, DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Partition Si as Si = ( S11 S12 ) and compute S such that +C ( 0 S22 ) +C +C S*S' = S11*S11' + (1-ALPHAC**2)*S12*S12'. +C + CALL DLACPY( 'Upper', N, N, DWORK(KU), NNW, S, LDS ) + IF( ALPHAC.NE.ZERO ) THEN + T = SQRT( ONE - ALPHAC*ALPHAC ) + DO 50 J = KU + NNW*N, KU + NNW*(NNW-1), NNW + CALL DSCAL( N, T, DWORK(J), 1 ) + 50 CONTINUE + END IF + IF( ALPHAC.LT.ONE .AND. NW.GT.0 ) THEN + KTAU = N*NNW + 1 + KW = KTAU + N + CALL MB04ND( 'Full', N, 0, NW, S, LDS, DWORK(KU+NNW*N), NNW, + $ DUM, 1, DUM, 1, DWORK(KTAU), DWORK(KW) ) +C + DO 70 J = 1, N + IF ( S(J,J).LT.ZERO ) THEN + DO 60 I = 1, J + S(I,J) = -S(I,J) + 60 CONTINUE + END IF + 70 CONTINUE + END IF +C + IF( LSAME( JOBC, 'E' ) .AND. ALPHAC.LT.ONE ) THEN +C +C Form X = -A*(S*S')-(S*S')*A' if DICO = 'C', or +C X = -A*(S*S')*A'+(S*S') if DICO = 'D'. +C + CALL DLACPY( 'Upper', N, N, S, LDS, DWORK(KU), N ) + CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', N, + $ -ONE, ZERO, S, LDS, DWORK(KAW), NNW, DWORK(KU), + $ N, IERR ) +C +C Compute the eigendecomposition of X as X = Z*Sigma*Z'. +C + KU = N + 1 + CALL DSYEV( 'Vectors', 'Upper', N, S, LDS, DWORK, DWORK(KU), + $ LDWORK-N, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + WORK = MAX( WORK, DWORK(KU) + DBLE( N ) ) +C +C Partition Sigma = (Sigma1,Sigma2), such that +C Sigma1 =< 0, Sigma2 > 0. +C Partition correspondingly Z = [Z1 Z2]. +C + TOL = MAX( ABS( DWORK(1) ), ABS( DWORK(N) ) ) + $ * DLAMCH( 'Epsilon') +C _ +C Form B = [ Z2*sqrt(Sigma2) ] +C + MBBAR = 0 + I = KU + DO 80 J = 1, N + IF( DWORK(J).GT.TOL ) THEN + MBBAR = MBBAR + 1 + CALL DSCAL( N, SQRT( DWORK(J) ), S(1,J), 1 ) + CALL DCOPY( N, S(1,J), 1, DWORK(I), 1 ) + I = I + N + END IF + 80 CONTINUE +C +C Solve for the Cholesky factor S of P, P = S*S', +C the continuous-time Lyapunov equation (if DICO = 'C') +C _ _ +C A*P + P*A' + t^2*B*B' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C _ _ +C A*P*A' - P + t^2*B*B' = 0. +C +C Workspace: need maximum N*(N + 6); +C prefer larger. +C + KTAU = KU + MBBAR*N + KW = KTAU + N +C + CALL SB03OU( DISCR, .TRUE., N, MBBAR, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), S, LDS, T, DWORK(KW), LDWORK-KW+1, + $ IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + SCALEC = SCALEC*T + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) + END IF +C + ELSE +C +C Solve for the Cholesky factor S of P, P = S*S', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C A*P + P*A' + scalec^2*B*B' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C A*P*A' - P + scalec^2*B*B' = 0. +C +C Workspace: need N*(M+5); +C prefer larger. +C + KU = 1 + KTAU = KU + N*M + KW = KTAU + N +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), N ) + CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KU), N, + $ DWORK(KTAU), S, LDS, SCALEC, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) + END IF +C +C Save optimal workspace. +C + DWORK(1) = WORK +C + RETURN +C *** Last line of AB09IY *** + END diff --git a/mex/sources/libslicot/AB09JD.f b/mex/sources/libslicot/AB09JD.f new file mode 100644 index 000000000..8729aa4e8 --- /dev/null +++ b/mex/sources/libslicot/AB09JD.f @@ -0,0 +1,1482 @@ + SUBROUTINE AB09JD( JOBV, JOBW, JOBINV, DICO, EQUIL, ORDSEL, + $ N, NV, NW, M, P, NR, ALPHA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AV, LDAV, BV, LDBV, + $ CV, LDCV, DV, LDDV, AW, LDAW, BW, LDBW, + $ CW, LDCW, DW, LDDW, NS, HSV, TOL1, TOL2, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the frequency +C weighted optimal Hankel-norm approximation method. +C The Hankel norm of the weighted error +C +C op(V)*(G-Gr)*op(W) +C +C is minimized, where G and Gr are the transfer-function matrices +C of the original and reduced systems, respectively, V and W are +C invertible transfer-function matrices representing the left and +C right frequency weights, and op(X) denotes X, inv(X), conj(X) or +C conj(inv(X)). V and W are specified by their state space +C realizations (AV,BV,CV,DV) and (AW,BW,CW,DW), respectively. +C When minimizing ||V*(G-Gr)*W||, V and W must be antistable. +C When minimizing inv(V)*(G-Gr)*inv(W), V and W must have only +C antistable zeros. +C When minimizing conj(V)*(G-Gr)*conj(W), V and W must be stable. +C When minimizing conj(inv(V))*(G-Gr)*conj(inv(W)), V and W must +C be minimum-phase. +C If the original system is unstable, then the frequency weighted +C Hankel-norm approximation is computed only for the +C ALPHA-stable part of the system. +C +C For a transfer-function matrix G, conj(G) denotes the conjugate +C of G given by G'(-s) for a continuous-time system or G'(1/z) +C for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBV CHARACTER*1 +C Specifies the left frequency-weighting as follows: +C = 'N': V = I; +C = 'V': op(V) = V; +C = 'I': op(V) = inv(V); +C = 'C': op(V) = conj(V); +C = 'R': op(V) = conj(inv(V)). +C +C JOBW CHARACTER*1 +C Specifies the right frequency-weighting as follows: +C = 'N': W = I; +C = 'W': op(W) = W; +C = 'I': op(W) = inv(W); +C = 'C': op(W) = conj(W); +C = 'R': op(W) = conj(inv(W)). +C +C JOBINV CHARACTER*1 +C Specifies the computational approach to be used as +C follows: +C = 'N': use the inverse free descriptor system approach; +C = 'I': use the inversion based standard approach; +C = 'A': switch automatically to the inverse free +C descriptor approach in case of badly conditioned +C feedthrough matrices in V or W (see METHOD). +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C NV (input) INTEGER +C The order of the realization of the left frequency +C weighting V, i.e., the order of the matrix AV. NV >= 0. +C +C NW (input) INTEGER +C The order of the realization of the right frequency +C weighting W, i.e., the order of the matrix AW. NW >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the +C multiplicity of the Hankel singular value HSV(NR-NU+1), +C NR is the desired order on entry, and NMIN is the order +C of a minimal realization of the ALPHA-stable part of the +C given system; NMIN is determined as the number of Hankel +C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where +C EPS is the machine precision (see LAPACK Library Routine +C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the +C ALPHA-stable part of the weighted system (computed in +C HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, if JOBV <> 'N', the leading NV-by-NV part of +C this array must contain the state matrix AV of a state +C space realization of the left frequency weighting V. +C On exit, if JOBV <> 'N', and INFO = 0, the leading +C NV-by-NV part of this array contains the real Schur form +C of AV. +C AV is not referenced if JOBV = 'N'. +C +C LDAV INTEGER +C The leading dimension of the array AV. +C LDAV >= MAX(1,NV), if JOBV <> 'N'; +C LDAV >= 1, if JOBV = 'N'. +C +C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) +C On entry, if JOBV <> 'N', the leading NV-by-P part of +C this array must contain the input matrix BV of a state +C space realization of the left frequency weighting V. +C On exit, if JOBV <> 'N', and INFO = 0, the leading +C NV-by-P part of this array contains the transformed +C input matrix BV corresponding to the transformed AV. +C BV is not referenced if JOBV = 'N'. +C +C LDBV INTEGER +C The leading dimension of the array BV. +C LDBV >= MAX(1,NV), if JOBV <> 'N'; +C LDBV >= 1, if JOBV = 'N'. +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, if JOBV <> 'N', the leading P-by-NV part of +C this array must contain the output matrix CV of a state +C space realization of the left frequency weighting V. +C On exit, if JOBV <> 'N', and INFO = 0, the leading +C P-by-NV part of this array contains the transformed output +C matrix CV corresponding to the transformed AV. +C CV is not referenced if JOBV = 'N'. +C +C LDCV INTEGER +C The leading dimension of the array CV. +C LDCV >= MAX(1,P), if JOBV <> 'N'; +C LDCV >= 1, if JOBV = 'N'. +C +C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) +C If JOBV <> 'N', the leading P-by-P part of this array +C must contain the feedthrough matrix DV of a state space +C realization of the left frequency weighting V. +C DV is not referenced if JOBV = 'N'. +C +C LDDV INTEGER +C The leading dimension of the array DV. +C LDDV >= MAX(1,P), if JOBV <> 'N'; +C LDDV >= 1, if JOBV = 'N'. +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, if JOBW <> 'N', the leading NW-by-NW part of +C this array must contain the state matrix AW of a state +C space realization of the right frequency weighting W. +C On exit, if JOBW <> 'N', and INFO = 0, the leading +C NW-by-NW part of this array contains the real Schur form +C of AW. +C AW is not referenced if JOBW = 'N'. +C +C LDAW INTEGER +C The leading dimension of the array AW. +C LDAW >= MAX(1,NW), if JOBW <> 'N'; +C LDAW >= 1, if JOBW = 'N'. +C +C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) +C On entry, if JOBW <> 'N', the leading NW-by-M part of +C this array must contain the input matrix BW of a state +C space realization of the right frequency weighting W. +C On exit, if JOBW <> 'N', and INFO = 0, the leading +C NW-by-M part of this array contains the transformed +C input matrix BW corresponding to the transformed AW. +C BW is not referenced if JOBW = 'N'. +C +C LDBW INTEGER +C The leading dimension of the array BW. +C LDBW >= MAX(1,NW), if JOBW <> 'N'; +C LDBW >= 1, if JOBW = 'N'. +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, if JOBW <> 'N', the leading M-by-NW part of +C this array must contain the output matrix CW of a state +C space realization of the right frequency weighting W. +C On exit, if JOBW <> 'N', and INFO = 0, the leading +C M-by-NW part of this array contains the transformed output +C matrix CW corresponding to the transformed AW. +C CW is not referenced if JOBW = 'N'. +C +C LDCW INTEGER +C The leading dimension of the array CW. +C LDCW >= MAX(1,M), if JOBW <> 'N'; +C LDCW >= 1, if JOBW = 'N'. +C +C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) +C If JOBW <> 'N', the leading M-by-M part of this array +C must contain the feedthrough matrix DW of a state space +C realization of the right frequency weighting W. +C DW is not referenced if JOBW = 'N'. +C +C LDDW INTEGER +C The leading dimension of the array DW. +C LDDW >= MAX(1,M), if JOBW <> 'N'; +C LDDW >= 1, if JOBW = 'N'. +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of this array contain +C the Hankel singular values, ordered decreasingly, of the +C projection G1s of op(V)*G1*op(W) (see METHOD), where G1 +C is the ALPHA-stable part of the original system. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(G1s), where c is a constant in the +C interval [0.00001,0.001], and HNORM(G1s) is the +C Hankel-norm of the projection G1s of op(V)*G1*op(W) +C (see METHOD), computed in HSV(1). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*HNORM(G1s), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C TOL1 < 1. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*HNORM(G1s). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C TOL2 < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M,c,d), if DICO = 'C', +C LIWORK = MAX(1,N,M,c,d), if DICO = 'D', where +C c = 0, if JOBV = 'N', +C c = MAX(2*P,NV+P+N+6,2*NV+P+2), if JOBV <> 'N', +C d = 0, if JOBW = 'N', +C d = MAX(2*M,NW+M+N+6,2*NW+M+2), if JOBW <> 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where +C for NVP = NV+P and NWM = NW+M we have +C LDW1 = 0 if JOBV = 'N' and +C LDW1 = 2*NVP*(NVP+P) + P*P + +C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), +C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) +C if JOBV <> 'N', +C LDW2 = 0 if JOBW = 'N' and +C LDW2 = 2*NWM*(NWM+M) + M*M + +C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), +C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) +C if JOBW <> 'N', +C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system. In this case, the resulting NR is set equal +C to NSMIN. +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system. In this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable +C diagonal blocks failed because of very close +C eigenvalues; +C = 3: the reduction of AV to a real Schur form failed; +C = 4: the reduction of AW to a real Schur form failed; +C = 5: the reduction to generalized Schur form of the +C descriptor pair corresponding to the inverse of V +C failed; +C = 6: the reduction to generalized Schur form of the +C descriptor pair corresponding to the inverse of W +C failed; +C = 7: the computation of Hankel singular values failed; +C = 8: the computation of stable projection in the +C Hankel-norm approximation algorithm failed; +C = 9: the order of computed stable projection in the +C Hankel-norm approximation algorithm differs +C from the order of Hankel-norm approximation; +C = 10: the reduction of AV-BV*inv(DV)*CV to a +C real Schur form failed; +C = 11: the reduction of AW-BW*inv(DW)*CW to a +C real Schur form failed; +C = 12: the solution of the Sylvester equation failed +C because the poles of V (if JOBV = 'V') or of +C conj(V) (if JOBV = 'C') are not distinct from +C the poles of G1 (see METHOD); +C = 13: the solution of the Sylvester equation failed +C because the poles of W (if JOBW = 'W') or of +C conj(W) (if JOBW = 'C') are not distinct from +C the poles of G1 (see METHOD); +C = 14: the solution of the Sylvester equation failed +C because the zeros of V (if JOBV = 'I') or of +C conj(V) (if JOBV = 'R') are not distinct from +C the poles of G1sr (see METHOD); +C = 15: the solution of the Sylvester equation failed +C because the zeros of W (if JOBW = 'I') or of +C conj(W) (if JOBW = 'R') are not distinct from +C the poles of G1sr (see METHOD); +C = 16: the solution of the generalized Sylvester system +C failed because the zeros of V (if JOBV = 'I') or +C of conj(V) (if JOBV = 'R') are not distinct from +C the poles of G1sr (see METHOD); +C = 17: the solution of the generalized Sylvester system +C failed because the zeros of W (if JOBW = 'I') or +C of conj(W) (if JOBW = 'R') are not distinct from +C the poles of G1sr (see METHOD); +C = 18: op(V) is not antistable; +C = 19: op(W) is not antistable; +C = 20: V is not invertible; +C = 21: W is not invertible. +C +C METHOD +C +C Let G be the transfer-function matrix of the original +C linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09JD determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (2) +C +C such that the corresponding transfer-function matrix Gr minimizes +C the Hankel-norm of the frequency-weighted error +C +C op(V)*(G-Gr)*op(W). (3) +C +C For minimizing (3) with op(V) = V and op(W) = W, V and W are +C assumed to have poles distinct from those of G, while with +C op(V) = conj(V) and op(W) = conj(W), conj(V) and conj(W) are +C assumed to have poles distinct from those of G. For minimizing (3) +C with op(V) = inv(V) and op(W) = inv(W), V and W are assumed to +C have zeros distinct from the poles of G, while with +C op(V) = conj(inv(V)) and op(W) = conj(inv(W)), conj(V) and conj(W) +C are assumed to have zeros distinct from the poles of G. +C +C Note: conj(G) = G'(-s) for a continuous-time system and +C conj(G) = G'(1/z) for a discrete-time system. +C +C The following procedure is used to reduce G (see [1]): +C +C 1) Decompose additively G as +C +C G = G1 + G2, +C +C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and +C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. +C +C 2) Compute G1s, the projection of op(V)*G1*op(W) containing the +C poles of G1, using explicit formulas [4] or the inverse-free +C descriptor system formulas of [5]. +C +C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s, +C of order r. +C +C 4) Compute G1r, the projection of inv(op(V))*G1sr*inv(op(W)) +C containing the poles of G1sr, using explicit formulas [4] +C or the inverse-free descriptor system formulas of [5]. +C +C 5) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the weighted ALPHA-stable part G1s at step 3, the +C optimal Hankel-norm approximation method of [2], based on the +C square-root balancing projection formulas of [3], is employed. +C +C The optimal weighted approximation error satisfies +C +C HNORM[op(V)*(G-Gr)*op(W)] >= S(r+1), +C +C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the +C transfer-function matrix computed at step 2 of the above +C procedure, and HNORM(.) denotes the Hankel-norm. +C +C REFERENCES +C +C [1] Latham, G.A. and Anderson, B.D.O. +C Frequency-weighted optimal Hankel-norm approximation of stable +C transfer functions. +C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. +C +C [2] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [3] Tombs, M.S. and Postlethwaite, I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [4] Varga, A. +C Explicit formulas for an efficient implementation +C of the frequency-weighting model reduction approach. +C Proc. 1993 European Control Conference, Groningen, NL, +C pp. 693-696, 1993. +C +C [5] Varga, A. +C Efficient and numerically reliable implementation of the +C frequency-weighted Hankel-norm approximation model reduction +C approach. +C Proc. 2001 ECC, Porto, Portugal, 2001. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2001. +C D. Sima, University of Bucharest, April 2001. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C March 2005. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, P0001, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, P0001 = 0.0001D0, + $ ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBINV, JOBV, JOBW, ORDSEL + INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, + $ NR, NS, NV, NW, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), + $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), + $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), + $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), + $ HSV(*) +C .. Local Scalars .. + CHARACTER JOBVL, JOBWL + LOGICAL AUTOM, CONJV, CONJW, DISCR, FIXORD, FRWGHT, + $ INVFR, LEFTI, LEFTW, RIGHTI, RIGHTW + INTEGER IERR, IWARNL, KAV, KAW, KBV, KBW, KCV, KCW, KDV, + $ KDW, KEV, KEW, KI, KL, KU, KW, LDABV, LDABW, + $ LDCDV, LDCDW, LW, NRA, NU, NU1, NVP, NWM, RANK + DOUBLE PRECISION ALPWRK, MAXRED, RCOND, SQREPS, TOL, WRKOPT +C .. Local Arrays .. + DOUBLE PRECISION TEMP(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB07ND, AB08MD, AB09CX, AB09JV, AB09JW, AG07BD, + $ DLACPY, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFTI = LSAME( JOBV, 'I' ) .OR. LSAME( JOBV, 'R' ) + LEFTW = LSAME( JOBV, 'V' ) .OR. LSAME( JOBV, 'C' ) .OR. LEFTI + CONJV = LSAME( JOBV, 'C' ) .OR. LSAME( JOBV, 'R' ) + RIGHTI = LSAME( JOBW, 'I' ) .OR. LSAME( JOBW, 'R' ) + RIGHTW = LSAME( JOBW, 'W' ) .OR. LSAME( JOBW, 'C' ) .OR. RIGHTI + CONJW = LSAME( JOBW, 'C' ) .OR. LSAME( JOBW, 'R' ) + FRWGHT = LEFTW .OR. RIGHTW + INVFR = LSAME( JOBINV, 'N' ) + AUTOM = LSAME( JOBINV, 'A' ) +C + LW = 1 + IF( LEFTW ) THEN + NVP = NV + P + LW = MAX( LW, 2*NVP*( NVP + P ) + P*P + + $ MAX( 2*NVP*NVP + MAX( 11*NVP + 16, P*NVP ), + $ NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ) ) + END IF + IF( RIGHTW ) THEN + NWM = NW + M + LW = MAX( LW, 2*NWM*( NWM + M ) + M*M + + $ MAX( 2*NWM*NWM + MAX( 11*NWM + 16, M*NWM ), + $ NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ) ) + END IF + LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) + LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( JOBV, 'N' ) .OR. LEFTW ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOBW, 'N' ) .OR. RIGHTW ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( INVFR .OR. AUTOM .OR. LSAME( JOBINV, 'I' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( NV.LT.0 ) THEN + INFO = -8 + ELSE IF( NW.LT.0 ) THEN + INFO = -9 + ELSE IF( M.LT.0 ) THEN + INFO = -10 + ELSE IF( P.LT.0 ) THEN + INFO = -11 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -12 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -13 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -21 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -23 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -25 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN + INFO = -27 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN + INFO = -29 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -31 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -33 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -35 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -37 + ELSE IF( TOL1.GE.ONE ) THEN + INFO = -40 + ELSE IF( ( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) + $ .OR. TOL2.GE.ONE ) THEN + INFO = -41 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -44 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NS = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + SQREPS = SQRT( DLAMCH( 'E' ) ) + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQREPS + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQREPS + END IF +C +C Allocate working storage. +C + KU = 1 + KL = KU + N*N + KI = KL + N + KW = KI + N +C +C Compute an additive decomposition G = G1 + G2, where G1 +C is the ALPHA-stable projection of G. +C +C Reduce A to a block-diagonal real Schur form, with the NU-th order +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), + $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) + IWARNL = 0 +C + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 + IF( CONJV ) THEN + JOBVL = 'C' + ELSE + JOBVL = 'V' + END IF + IF( CONJW ) THEN + JOBWL = 'C' + ELSE + JOBWL = 'W' + END IF + IF( LEFTW ) THEN +C +C Check if V is invertible. +C Real workspace: need (NV+P)**2 + MAX( P + MAX(3*P,NV), +C MIN(P+1,NV) + MAX(3*(P+1),NV+P) ); +C prefer larger. +C Integer workspace: need 2*NV+P+2. +C + TOL = ZERO + CALL AB08MD( 'S', NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, + $ DV, LDDV, RANK, TOL, IWORK, DWORK, LDWORK, + $ IERR ) + IF( RANK.NE.P ) THEN + INFO = 20 + RETURN + END IF + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF( LEFTI ) THEN + IF( INVFR ) THEN + IERR = 1 + ELSE +C +C Allocate storage for a standard inverse of V. +C Workspace: need NV*(NV+2*P) + P*P. +C + KAV = 1 + KBV = KAV + NV*NV + KCV = KBV + NV*P + KDV = KCV + P*NV + KW = KDV + P*P +C + LDABV = MAX( NV, 1 ) + LDCDV = P + CALL DLACPY( 'Full', NV, NV, AV, LDAV, + $ DWORK(KAV), LDABV ) + CALL DLACPY( 'Full', NV, P, BV, LDBV, + $ DWORK(KBV), LDABV ) + CALL DLACPY( 'Full', P, NV, CV, LDCV, + $ DWORK(KCV), LDCDV ) + CALL DLACPY( 'Full', P, P, DV, LDDV, + $ DWORK(KDV), LDCDV ) +C +C Compute the standard inverse of V. +C Additional real workspace: need MAX(1,4*P); +C prefer larger. +C Integer workspace: need 2*P. +C + CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, + $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C Check if inversion is accurate. +C + IF( AUTOM ) THEN + IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 + ELSE + IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 + END IF + IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN + INFO = 20 + RETURN + END IF + END IF +C + IF( IERR.NE.0 ) THEN +C +C Allocate storage for a descriptor inverse of V. +C + KAV = 1 + KEV = KAV + NVP*NVP + KBV = KEV + NVP*NVP + KCV = KBV + NVP*P + KDV = KCV + P*NVP + KW = KDV + P*P +C + LDABV = MAX( NVP, 1 ) + LDCDV = P +C +C DV is singular or ill-conditioned. +C Form a descriptor inverse of V. +C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. +C + CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, + $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, + $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using descriptor inverse of V +C of order NVP = NV + P. +C Additional real workspace: need +C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), +C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); +C prefer larger. +C Integer workspace: need NVP+N+6. +C + CALL AB09JV( JOBVL, DICO, 'G', 'C', NS, M, P, NVP, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, + $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, + $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, + $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 5 + ELSE IF( IERR.EQ.2 ) THEN + INFO = 16 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 18 + END IF + RETURN + END IF + ELSE +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using explicit inverse of V. +C Additional real workspace: need +C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBVL = 'V', +C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; +C prefer larger. +C + CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, + $ TEMP, 1, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 10 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 14 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 18 + END IF + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) + ELSE +C +C Compute the projection of V*G1 or conj(V)*G1 containing the +C poles of G. +C +C Workspace need: +C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBVL = 'V', +C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; +C prefer larger. +C + CALL AB09JV( JOBVL, DICO, 'I', 'C', NS, M, P, NV, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, AV, LDAV, + $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, + $ DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 3 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 12 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 18 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C + IF( RIGHTW ) THEN +C +C Check if W is invertible. +C Real workspace: need (NW+M)**2 + MAX( M + MAX(3*M,NW), +C MIN(M+1,NW) + MAX(3*(M+1),NW+M) ); +C prefer larger. +C Integer workspace: need 2*NW+M+2. +C + TOL = ZERO + CALL AB08MD( 'S', NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, + $ DW, LDDW, RANK, TOL, IWORK, DWORK, LDWORK, + $ IERR ) + IF( RANK.NE.M ) THEN + INFO = 21 + RETURN + END IF + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF( RIGHTI ) THEN + IF( INVFR ) THEN + IERR = 1 + ELSE +C +C Allocate storage for a standard inverse of W. +C Workspace: need NW*(NW+2*M) + M*M. +C + KAW = 1 + KBW = KAW + NW*NW + KCW = KBW + NW*M + KDW = KCW + M*NW + KW = KDW + M*M +C + LDABW = MAX( NW, 1 ) + LDCDW = M + CALL DLACPY( 'Full', NW, NW, AW, LDAW, + $ DWORK(KAW), LDABW ) + CALL DLACPY( 'Full', NW, M, BW, LDBW, + $ DWORK(KBW), LDABW ) + CALL DLACPY( 'Full', M, NW, CW, LDCW, + $ DWORK(KCW), LDCDW ) + CALL DLACPY( 'Full', M, M, DW, LDDW, + $ DWORK(KDW), LDCDW ) +C +C Compute the standard inverse of W. +C Additional real workspace: need MAX(1,4*M); +C prefer larger. +C Integer workspace: need 2*M. +C + CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C Check if inversion is accurate. +C + IF( AUTOM ) THEN + IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 + ELSE + IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 + END IF + IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN + INFO = 21 + RETURN + END IF + END IF +C + IF( IERR.NE.0 ) THEN +C +C Allocate storage for a descriptor inverse of W. +C + KAW = 1 + KEW = KAW + NWM*NWM + KBW = KEW + NWM*NWM + KCW = KBW + NWM*M + KDW = KCW + M*NWM + KW = KDW + M*M +C + LDABW = MAX( NWM, 1 ) + LDCDW = M +C +C DW is singular or ill-conditioned. +C Form the descriptor inverse of W. +C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. +C + CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, + $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, + $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using descriptor inverse of W +C of order NWM = NW + M. +C Additional real workspace: need +C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), +C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); +C prefer larger. +C Integer workspace: need NWM+N+6. +C + CALL AB09JW( JOBWL, DICO, 'G', 'C', NS, M, P, NWM, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, + $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 6 + ELSE IF( IERR.EQ.2 ) THEN + INFO = 17 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 19 + END IF + RETURN + END IF + ELSE +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using explicit inverse of W. +C Additional real workspace: need +C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBWL = 'W', +C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; +C prefer larger. +C + CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, + $ TEMP, 1, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 11 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 15 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 19 + END IF + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) + ELSE +C +C Compute the projection G1s of V*G1*W or conj(V)*G1*conj(W) +C containing the poles of G. +C +C Workspace need: +C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C b = 0, if DICO = 'C' or JOBWL = 'W', +C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; +C prefer larger. +C + CALL AB09JW( JOBWL, DICO, 'I', 'C', NS, M, P, NW, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, + $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, + $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 4 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 13 + ELSE IF( IERR.EQ.4 ) THEN + INFO = 19 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C +C Determine a reduced order approximation G1sr of G1s using the +C Hankel-norm approximation method. The resulting A(NU1:N,NU1:N) +C is further in a real Schur form. +C +C Workspace: need MAX( LDW3, LDW4 ), +C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ); +C prefer larger. +C + CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) +C + IF( IERR.NE.0 ) THEN +C +C Set INFO = 7, 8 or 9. +C + INFO = IERR + 5 + RETURN + END IF +C + IWARN = MAX( IWARNL, IWARN ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF( LEFTW ) THEN + IF( .NOT.LEFTI ) THEN + IF( INVFR ) THEN + IERR = 1 + ELSE +C +C Allocate storage for a standard inverse of V. +C Workspace: need NV*(NV+2*P) + P*P. +C + KAV = 1 + KBV = KAV + NV*NV + KCV = KBV + NV*P + KDV = KCV + P*NV + KW = KDV + P*P +C + LDABV = MAX( NV, 1 ) + LDCDV = P + CALL DLACPY( 'Full', NV, NV, AV, LDAV, + $ DWORK(KAV), LDABV ) + CALL DLACPY( 'Full', NV, P, BV, LDBV, + $ DWORK(KBV), LDABV ) + CALL DLACPY( 'Full', P, NV, CV, LDCV, + $ DWORK(KCV), LDCDV ) + CALL DLACPY( 'Full', P, P, DV, LDDV, + $ DWORK(KDV), LDCDV ) +C +C Compute the standard inverse of V. +C Additional real workspace: need MAX(1,4*P); +C prefer larger. +C Integer workspace: need 2*P. +C + CALL AB07ND( NV, P, DWORK(KAV), LDABV, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, + $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C Check if inversion is accurate. +C + IF( AUTOM ) THEN + IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 + ELSE + IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 + END IF + IF( IERR.NE.0 .AND. NV.EQ.0 ) THEN + INFO = 20 + RETURN + END IF + END IF +C + IF( IERR.NE.0 ) THEN +C +C Allocate storage for a descriptor inverse of V. +C + KAV = 1 + KEV = KAV + NVP*NVP + KBV = KEV + NVP*NVP + KCV = KBV + NVP*P + KDV = KCV + P*NVP + KW = KDV + P*P +C + LDABV = MAX( NVP, 1 ) + LDCDV = P +C +C DV is singular or ill-conditioned. +C Form a descriptor inverse of V. +C Workspace: need 2*(NV+P)*(NV+2*P) + P*P. +C + CALL AG07BD( 'I', NV, P, AV, LDAV, TEMP, 1, BV, LDBV, + $ CV, LDCV, DV, LDDV, DWORK(KAV), LDABV, + $ DWORK(KEV), LDABV, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IERR ) +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using descriptor inverse of V +C of order NVP = NV + P. +C Additional real workspace: need +C MAX( 2*NVP*NVP + MAX( 11*NVP+16, P*NVP ), +C NVP*N + MAX( NVP*N+N*N, P*N, P*M ) ); +C prefer larger. +C Integer workspace: need NVP+N+6. +C + CALL AB09JV( JOBVL, DICO, 'G', 'N', NRA, M, P, NVP, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, + $ DWORK(KAV), LDABV, DWORK(KEV), LDABV, + $ DWORK(KBV), LDABV, DWORK(KCV), LDCDV, + $ DWORK(KDV), LDCDV, IWORK, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 5 + ELSE IF( IERR.EQ.2 ) THEN + INFO = 16 + END IF + RETURN + END IF + ELSE +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using explicit inverse of V. +C Additional real workspace: need +C MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBVL = 'V', +C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; +C prefer larger. +C + CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAV), LDABV, + $ TEMP, 1, DWORK(KBV), LDABV, + $ DWORK(KCV), LDCDV, DWORK(KDV), LDCDV, IWORK, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 10 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 14 + END IF + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) + ELSE +C +C Compute the projection of V*G1sr or conj(V)*G1sr containing +C the poles of G. +C +C Workspace need: +C real MAX( 1, NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBVL = 'V', +C a = 2*NV, if DICO = 'D' and JOBVL = 'C'; +C prefer larger. +C + CALL AB09JV( JOBVL, DICO, 'I', 'N', NRA, M, P, NV, P, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, AV, LDAV, + $ TEMP, 1, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, + $ DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 3 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 12 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C + IF( RIGHTW ) THEN + IF( .NOT.RIGHTI ) THEN + IF( INVFR ) THEN + IERR = 1 + ELSE +C +C Allocate storage for a standard inverse of W. +C Workspace: need NW*(NW+2*M) + M*M. +C + KAW = 1 + KBW = KAW + NW*NW + KCW = KBW + NW*M + KDW = KCW + M*NW + KW = KDW + M*M +C + LDABW = MAX( NW, 1 ) + LDCDW = M + CALL DLACPY( 'Full', NW, NW, AW, LDAW, + $ DWORK(KAW), LDABW ) + CALL DLACPY( 'Full', NW, M, BW, LDBW, + $ DWORK(KBW), LDABW ) + CALL DLACPY( 'Full', M, NW, CW, LDCW, + $ DWORK(KCW), LDCDW ) + CALL DLACPY( 'Full', M, M, DW, LDDW, + $ DWORK(KDW), LDCDW ) +C +C Compute the standard inverse of W. +C Additional real workspace: need MAX(1,4*M); +C prefer larger. +C Integer workspace: need 2*M. +C + CALL AB07ND( NW, M, DWORK(KAW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ RCOND, IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C Check if inversion is accurate. +C + IF( AUTOM ) THEN + IF( IERR.EQ.0 .AND. RCOND.LE.P0001 ) IERR = 1 + ELSE + IF( IERR.EQ.0 .AND. RCOND.LE.SQREPS ) IERR = 1 + END IF + IF( IERR.NE.0 .AND. NW.EQ.0 ) THEN + INFO = 21 + RETURN + END IF + END IF +C + IF( IERR.NE.0 ) THEN +C +C Allocate storage for a descriptor inverse of W. +C + KAW = 1 + KEW = KAW + NWM*NWM + KBW = KEW + NWM*NWM + KCW = KBW + NWM*M + KDW = KCW + M*NWM + KW = KDW + M*M +C + LDABW = MAX( NWM, 1 ) + LDCDW = M +C +C DW is singular or ill-conditioned. +C Form the descriptor inverse of W. +C Workspace: need 2*(NW+M)*(NW+2*M) + M*M. +C + CALL AG07BD( 'I', NW, M, AW, LDAW, TEMP, 1, BW, LDBW, + $ CW, LDCW, DW, LDDW, DWORK(KAW), LDABW, + $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, IERR ) +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using descriptor inverse of W +C of order NWM = NW + M. +C Additional real workspace: need +C MAX( 2*NWM*NWM + MAX( 11*NWM+16, M*NWM ), +C NWM*N + MAX( NWM*N+N*N, M*N, P*M ) ); +C prefer larger. +C Integer workspace: need NWM+N+6. +C + CALL AB09JW( JOBWL, DICO, 'G', 'N', NRA, M, P, NWM, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, + $ DWORK(KEW), LDABW, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 6 + ELSE IF( IERR.EQ.2 ) THEN + INFO = 17 + END IF + RETURN + END IF + ELSE +C +C Compute the projection containing the poles of weighted +C reduced ALPHA-stable part using explicit inverse of W. +C Additional real workspace: need +C MAX( NW*(NW+5), NW*N + MAX( a, M*N, P*M ) ) +C a = 0, if DICO = 'C' or JOBWL = 'W', +C a = 2*NW, if DICO = 'D' and JOBWL = 'C'; +C prefer larger. +C + CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, + $ C(1,NU1), LDC, D, LDD, DWORK(KAW), LDABW, + $ TEMP, 1, DWORK(KBW), LDABW, + $ DWORK(KCW), LDCDW, DWORK(KDW), LDCDW, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 11 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 15 + END IF + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW - 1 ) ) + ELSE +C +C Compute the projection G1r of V*G1sr*W or +C conj(V)*G1sr*conj(W) containing the poles of G. +C +C Workspace need: +C real MAX( 1, NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C b = 0, if DICO = 'C' or JOBWL = 'W', +C b = 2*NW, if DICO = 'D' and JOBWL = 'C'; +C prefer larger. +C + CALL AB09JW( JOBWL, DICO, 'I', 'N', NRA, M, P, NW, M, + $ A(NU1,NU1), LDA, B(NU1,1), LDB, C(1,NU1), LDC, + $ D, LDD, AW, LDAW, TEMP, 1, BW, LDBW, CW, LDCW, + $ DW, LDDW, IWORK, DWORK, LDWORK, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.1 ) THEN + INFO = 4 + ELSE IF( IERR.EQ.3 ) THEN + INFO = 13 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C + NR = NRA + NU + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB09JD *** + END diff --git a/mex/sources/libslicot/AB09JV.f b/mex/sources/libslicot/AB09JV.f new file mode 100644 index 000000000..5a7d08ab2 --- /dev/null +++ b/mex/sources/libslicot/AB09JV.f @@ -0,0 +1,958 @@ + SUBROUTINE AB09JV( JOB, DICO, JOBEV, STBCHK, N, M, P, NV, PV, + $ A, LDA, B, LDB, C, LDC, D, LDD, AV, LDAV, + $ EV, LDEV, BV, LDBV, CV, LDCV, DV, LDDV, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct a state-space representation (A,BS,CS,DS) of the +C projection of V*G or conj(V)*G containing the poles of G, from the +C state-space representations (A,B,C,D) and (AV-lambda*EV,BV,CV,DV), +C of the transfer-function matrices G and V, respectively. +C G is assumed to be a stable transfer-function matrix and +C the state matrix A must be in a real Schur form. +C When computing the stable projection of V*G, it is assumed +C that G and V have completely distinct poles. +C When computing the stable projection of conj(V)*G, it is assumed +C that G and conj(V) have completely distinct poles. +C +C Note: For a transfer-function matrix G, conj(G) denotes the +C conjugate of G given by G'(-s) for a continuous-time system or +C G'(1/z) for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the projection to be computed as follows: +C = 'V': compute the projection of V*G containing +C the poles of G; +C = 'C': compute the projection of conj(V)*G containing +C the poles of G. +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G and V are continuous-time systems; +C = 'D': G and V are discrete-time systems. +C +C JOBEV CHARACTER*1 +C Specifies whether EV is a general square or an identity +C matrix as follows: +C = 'G': EV is a general square matrix; +C = 'I': EV is the identity matrix. +C +C STBCHK CHARACTER*1 +C Specifies whether stability/antistability of V is to be +C checked as follows: +C = 'C': check stability if JOB = 'C' or antistability if +C JOB = 'V'; +C = 'N': do not check stability or antistability. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector of the system with +C the transfer-function matrix G. N >= 0. +C +C M (input) INTEGER +C The dimension of the input vector of the system with +C the transfer-function matrix G. M >= 0. +C +C P (input) INTEGER +C The dimension of the output vector of the system with the +C transfer-function matrix G, and also the dimension of +C the input vector if JOB = 'V', or of the output vector +C if JOB = 'C', of the system with the transfer-function +C matrix V. P >= 0. +C +C NV (input) INTEGER +C The dimension of the state vector of the system with +C the transfer-function matrix V. NV >= 0. +C +C PV (input) INTEGER +C The dimension of the output vector, if JOB = 'V', or +C of the input vector, if JOB = 'C', of the system with +C the transfer-function matrix V. PV >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system with the transfer-function +C matrix G in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain +C the input/state matrix B of the system with the +C transfer-function matrix G. The matrix BS is equal to B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading PV-by-N part of this +C array contains the output matrix CS of the projection of +C V*G, if JOB = 'V', or of conj(V)*G, if JOB = 'C'. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P,PV). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the feedthrough matrix D of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading PV-by-M part of +C this array contains the feedthrough matrix DS of the +C projection of V*G, if JOB = 'V', or of conj(V)*G, +C if JOB = 'C'. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,P,PV). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, the leading NV-by-NV part of this array must +C contain the state matrix AV of the system with the +C transfer-function matrix V. +C On exit, if INFO = 0, the leading NV-by-NV part of this +C array contains a condensed matrix as follows: +C if JOBEV = 'I', it contains the real Schur form of AV; +C if JOBEV = 'G' and JOB = 'V', it contains a quasi-upper +C triangular matrix representing the real Schur matrix +C in the real generalized Schur form of the pair (AV,EV); +C if JOBEV = 'G', JOB = 'C' and DICO = 'C', it contains a +C quasi-upper triangular matrix corresponding to the +C generalized real Schur form of the pair (AV',EV'); +C if JOBEV = 'G', JOB = 'C' and DICO = 'D', it contains an +C upper triangular matrix corresponding to the generalized +C real Schur form of the pair (EV',AV'). +C +C LDAV INTEGER +C The leading dimension of the array AV. LDAV >= MAX(1,NV). +C +C EV (input/output) DOUBLE PRECISION array, dimension (LDEV,NV) +C On entry, if JOBEV = 'G', the leading NV-by-NV part of +C this array must contain the descriptor matrix EV of the +C system with the transfer-function matrix V. +C If JOBEV = 'I', EV is assumed to be an identity matrix +C and is not referenced. +C On exit, if INFO = 0 and JOBEV = 'G', the leading NV-by-NV +C part of this array contains a condensed matrix as follows: +C if JOB = 'V', it contains an upper triangular matrix +C corresponding to the real generalized Schur form of the +C pair (AV,EV); +C if JOB = 'C' and DICO = 'C', it contains an upper +C triangular matrix corresponding to the generalized real +C Schur form of the pair (AV',EV'); +C if JOB = 'C' and DICO = 'D', it contains a quasi-upper +C triangular matrix corresponding to the generalized +C real Schur form of the pair (EV',AV'). +C +C LDEV INTEGER +C The leading dimension of the array EV. +C LDEV >= MAX(1,NV), if JOBEV = 'G'; +C LDEV >= 1, if JOBEV = 'I'. +C +C BV (input/output) DOUBLE PRECISION array, +C dimension (LDBV,MBV), where MBV = P, if JOB = 'V', and +C MBV = PV, if JOB = 'C'. +C On entry, the leading NV-by-MBV part of this array must +C contain the input matrix BV of the system with the +C transfer-function matrix V. +C On exit, if INFO = 0, the leading NV-by-MBV part of this +C array contains Q'*BV, where Q is the orthogonal matrix +C that reduces AV to the real Schur form or the left +C orthogonal matrix used to reduce the pair (AV,EV), +C (AV',EV') or (EV',AV') to the generalized real Schur form. +C +C LDBV INTEGER +C The leading dimension of the array BV. LDBV >= MAX(1,NV). +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, the leading PCV-by-NV part of this array must +C contain the output matrix CV of the system with the +C transfer-function matrix V, where PCV = PV, if JOB = 'V', +C or PCV = P, if JOB = 'C'. +C On exit, if INFO = 0, the leading PCV-by-NV part of this +C array contains CV*Q, where Q is the orthogonal matrix that +C reduces AV to the real Schur form, or CV*Z, where Z is the +C right orthogonal matrix used to reduce the pair (AV,EV), +C (AV',EV') or (EV',AV') to the generalized real Schur form. +C +C LDCV INTEGER +C The leading dimension of the array CV. +C LDCV >= MAX(1,PV) if JOB = 'V'; +C LDCV >= MAX(1,P) if JOB = 'C'. +C +C DV (input) DOUBLE PRECISION array, +C dimension (LDDV,MBV), where MBV = P, if JOB = 'V', and +C MBV = PV, if JOB = 'C'. +C The leading PCV-by-MBV part of this array must contain +C the feedthrough matrix DV of the system with the +C transfer-function matrix V, where PCV = PV, if JOB = 'V', +C or PCV = P, if JOB = 'C'. +C +C LDDV INTEGER +C The leading dimension of the array DV. +C LDDV >= MAX(1,PV) if JOB = 'V'; +C LDDV >= MAX(1,P) if JOB = 'C'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOBEV = 'I'; +C LIWORK = NV+N+6, if JOBEV = 'G'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= LW1, if JOBEV = 'I', +C LDWORK >= LW2, if JOBEV = 'G', where +C LW1 = MAX( 1, NV*(NV+5), NV*N + MAX( a, PV*N, PV*M ) ) +C a = 0, if DICO = 'C' or JOB = 'V', +C a = 2*NV, if DICO = 'D' and JOB = 'C'; +C LW2 = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), +C NV*N + MAX( NV*N+N*N, PV*N, PV*M ) ). +C For good performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of the pair (AV,EV) to the real +C generalized Schur form failed (JOBEV = 'G'), +C or the reduction of the matrix AV to the real +C Schur form failed (JOBEV = 'I); +C = 2: the solution of the Sylvester equation failed +C because the matrix A and the pencil AV-lambda*EV +C have common eigenvalues (if JOB = 'V'), or the +C pencil -AV-lambda*EV and A have common eigenvalues +C (if JOB = 'C' and DICO = 'C'), or the pencil +C AV-lambda*EV has an eigenvalue which is the +C reciprocal of one of eigenvalues of A +C (if JOB = 'C' and DICO = 'D'); +C = 3: the solution of the Sylvester equation failed +C because the matrices A and AV have common +C eigenvalues (if JOB = 'V'), or the matrices A +C and -AV have common eigenvalues (if JOB = 'C' and +C DICO = 'C'), or the matrix A has an eigenvalue +C which is the reciprocal of one of eigenvalues of AV +C (if JOB = 'C' and DICO = 'D'); +C = 4: JOB = 'V' and the pair (AV,EV) has not completely +C unstable generalized eigenvalues, or JOB = 'C' and +C the pair (AV,EV) has not completely stable +C generalized eigenvalues. +C +C METHOD +C +C If JOB = 'V', the matrices of the stable projection of V*G are +C computed as +C +C BS = B, CS = CV*X + DV*C, DS = DV*D, +C +C where X satisfies the generalized Sylvester equation +C +C AV*X - EV*X*A + BV*C = 0. +C +C If JOB = 'C', the matrices of the stable projection of conj(V)*G +C are computed using the following formulas: +C +C - for a continuous-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B, CS = BV'*X + DV'*C, DS = DV'*D, +C +C where X satisfies the generalized Sylvester equation +C +C AV'*X + EV'*X*A + CV'*C = 0. +C +C - for a discrete-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B, CS = BV'*X*A + DV'*C, DS = DV'*D + BV'*X*B, +C +C where X satisfies the generalized Sylvester equation +C +C EV'*X - AV'*X*A = CV'*C. +C +C REFERENCES +C +C [1] Varga, A. +C Efficient and numerically reliable implementation of the +C frequency-weighted Hankel-norm approximation model reduction +C approach. +C Proc. 2001 ECC, Porto, Portugal, 2001. +C +C [2] Zhou, K. +C Frequency-weighted H-infinity norm and optimal Hankel norm +C model reduction. +C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on numerically stable algorithms. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. +C D. Sima, University of Bucharest, March 2001. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, JOBEV, STBCHK + INTEGER INFO, LDA, LDAV, LDB, LDBV, LDC, LDCV, + $ LDD, LDDV, LDEV, LDWORK, M, N, NV, P, PV +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), B(LDB,*), BV(LDBV,*), + $ C(LDC,*), CV(LDCV,*), D(LDD,*), DV(LDDV,*), + $ DWORK(*), EV(LDEV,*) +C .. Local Scalars .. + CHARACTER*1 EVTYPE, STDOM + LOGICAL CONJS, DISCR, STABCK, UNITEV + DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK + INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, + $ KZ, LDW, LDWN, LW, SDIM +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL DELCTG, LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, + $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +C +C .. Executable Statements .. +C + CONJS = LSAME( JOB, 'C' ) + DISCR = LSAME( DICO, 'D' ) + UNITEV = LSAME( JOBEV, 'I' ) + STABCK = LSAME( STBCHK, 'C' ) +C + INFO = 0 + IF( UNITEV ) THEN + IF ( DISCR .AND. CONJS ) THEN + IA = 2*NV + ELSE + IA = 0 + END IF + LW = MAX( 1, NV*( NV + 5 ), NV*N + MAX( IA, PV*N, PV*M ) ) + ELSE + LW = MAX( 2*NV*NV + MAX( 11*NV+16, P*NV, PV*NV ), + $ NV*N + MAX( NV*N + N*N, PV*N, PV*M ) ) + END IF +C +C Test the input scalar arguments. +C + LDWN = MAX( 1, N ) + LDW = MAX( 1, NV ) + IF( .NOT. ( LSAME( JOB, 'V' ) .OR. CONJS ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBEV, 'G' ) .OR. UNITEV ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( NV.LT.0 ) THEN + INFO = -8 + ELSE IF( PV.LT.0 ) THEN + INFO = -9 + ELSE IF( LDA.LT.LDWN ) THEN + INFO = -11 + ELSE IF( LDB.LT.LDWN ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P, PV ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.MAX( 1, P, PV ) ) THEN + INFO = -17 + ELSE IF( LDAV.LT.LDW ) THEN + INFO = -19 + ELSE IF( LDEV.LT.1 .OR. ( .NOT.UNITEV .AND. LDEV.LT.NV ) ) THEN + INFO = -21 + ELSE IF( LDBV.LT.LDW ) THEN + INFO = -23 + ELSE IF( ( .NOT.CONJS .AND. LDCV.LT.MAX( 1, PV ) ) .OR. + $ ( CONJS .AND. LDCV.LT.MAX( 1, P ) ) ) THEN + INFO = -25 + ELSE IF( ( .NOT.CONJS .AND. LDDV.LT.MAX( 1, PV ) ) .OR. + $ ( CONJS .AND. LDDV.LT.MAX( 1, P ) ) ) THEN + INFO = -27 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -30 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09JV', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( P.EQ.0 .OR. PV.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Set options for stability/antistability checking. +C + IF( DISCR ) THEN + ALPHA = ONE + ELSE + ALPHA = ZERO + END IF +C + WORK = ONE + TOLINF = DLAMCH( 'Epsilon' ) +C + IF( UNITEV ) THEN +C +C EV is the identity matrix. +C + IF( NV.GT.0 ) THEN +C +C Reduce AV to the real Schur form using an orthogonal +C similarity transformation AV <- Q'*AV*Q and apply the +C transformation to BV and CV: BV <- Q'*BV and CV <- CV*Q. +C +C Workspace needed: NV*(NV+5); +C prefer larger. +C + KW = NV*( NV + 2 ) + 1 + IF( CONJS ) THEN + STDOM = 'S' + ALPHA = ALPHA + SQRT( TOLINF ) + CALL TB01WD( NV, PV, P, AV, LDAV, BV, LDBV, CV, LDCV, + $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), + $ DWORK(KW), LDWORK-KW+1, IERR ) + ELSE + STDOM = 'U' + ALPHA = ALPHA - SQRT( TOLINF ) + CALL TB01WD( NV, P, PV, AV, LDAV, BV, LDBV, CV, LDCV, + $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), + $ DWORK(KW), LDWORK-KW+1, IERR ) + END IF + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of eigenvalues of AV. +C + CALL AB09JX( DICO, STDOM, 'S', NV, ALPHA, DWORK, + $ DWORK(NV+1), DWORK, TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF +C + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C + END IF +C + KW = NV*N + 1 + IF( CONJS ) THEN +C +C Compute the projection of conj(V)*G. +C +C Total workspace needed: NV*N + MAX( a, PV*N, PV*M ), where +C a = 0, if DICO = 'C', +C a = 2*NV, if DICO = 'D'. +C +C Compute -CV'*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, + $ ZERO, DWORK, LDW ) +C + IF( DISCR ) THEN +C +C Compute X and SCALE satisfying +C +C AV'*X*A - X = -SCALE*CV'*C. +C +C Additional workspace needed: 2*NV. +C + CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, DWORK(KW), IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct CS = DV'*C + BV'*X*A/SCALE, +C DS = DV'*D + BV'*X*B/SCALE. +C +C Additional workspace needed: MAX( PV*N, PV*M ). +C +C C <- DV'*C. +C + CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) +C +C D <- DV'*D. +C + CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) +C +C C <- C + BV'*X*A/SCALE. +C + CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK, LDW, ZERO, DWORK(KW), PV ) + CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, + $ A, LDA, ONE, C, LDC ) +C +C D <- D + BV'*X*B/SCALE. +C + CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, + $ B, LDB, ONE, D, LDD ) + ELSE +C +C Compute X and SCALE satisfying +C +C AV'*X + X*A + SCALE*CV'*C = 0. +C + IF( N.GT.0 ) THEN + CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + END IF +C +C Construct CS = DV'*C + BV'*X/SCALE, +C DS = DV'*D. +C Additional workspace needed: MAX( PV*N, PV*M ). +C +C Construct C <- DV'*C + BV'*X/SCALE. +C + CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) + CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV'*D. +C + CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) + END IF + ELSE +C +C Compute the projection of V*G. +C +C Total workspace needed: NV*N + MAX( PV*N, PV*M ). +C +C Compute -BV*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, + $ ZERO, DWORK, LDW ) +C +C Compute X and SCALE satisfying +C +C AV*X - X*A + SCALE*BV*C = 0. +C + IF( N.GT.0 ) THEN + CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + END IF +C +C Construct CS = DV*C + CV*X/SCALE, +C DS = DV*D. +C Additional workspace needed: MAX( PV*N, PV*M ). +C +C Construct C <- DV*C + CV*X/SCALE. +C + CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) + CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV*D. +C + CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) + END IF + ELSE +C +C EV is a general matrix. +C + IF( NV.GT.0 ) THEN + TOLINF = TOLINF * DLANGE( '1', NV, NV, EV, LDEV, DWORK ) +C +C Reduce (AV,EV), or (AV',EV') or (EV',AV') to a generalized +C real Schur form using an orthogonal equivalence +C transformation and apply the orthogonal transformation +C appropriately to BV and CV, or CV' and BV'. +C +C Workspace needed: 2*NV*NV + MAX( 11*NV+16, NV*P, NV*PV ); +C prefer larger. +C + KQ = 1 + KZ = KQ + NV*NV + KAR = KZ + NV*NV + KAI = KAR + NV + KB = KAI + NV + KW = KB + NV +C + IF( CONJS ) THEN + STDOM = 'S' + ALPHA = ALPHA + SQRT( TOLINF ) +C +C Transpose AV and EV, if non-scalar. +C + DO 10 I = 1, NV - 1 + CALL DSWAP( NV-I, AV(I+1,I), 1, AV(I,I+1), LDAV ) + CALL DSWAP( NV-I, EV(I+1,I), 1, EV(I,I+1), LDEV ) + 10 CONTINUE +C + IF( DISCR ) THEN +C +C Reduce (EV',AV') to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*EV'*Z results in a quasi-triangular form +C and Q'*AV'*Z results upper triangular. +C Total workspace needed: 2*NV*NV + 11*NV + 16. +C + EVTYPE = 'R' + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NV, EV, LDEV, AV, LDAV, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + ELSE +C +C Reduce (AV',EV') to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*AV'*Z results in a quasi-triangular form +C and Q'*EV'*Z results upper triangular. +C Total workspace needed: 2*NV*NV + 11*NV + 16. +C + EVTYPE = 'G' + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + END IF + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of generalized +C eigenvalues of the pair (AV,EV). +C + CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Compute Z'*BV and CV*Q. +C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). +C + KW = KAR + CALL DLACPY( 'Full', NV, PV, BV, LDBV, DWORK(KW), LDW ) + CALL DGEMM( 'T', 'N', NV, PV, NV, ONE, DWORK(KZ), LDW, + $ DWORK(KW), LDW, ZERO, BV, LDBV ) + CALL DLACPY( 'Full', P, NV, CV, LDCV, DWORK(KW), P ) + CALL DGEMM( 'N', 'N', P, NV, NV, ONE, DWORK(KW), P, + $ DWORK(KQ), LDW, ZERO, CV, LDCV ) + ELSE +C +C Reduce (AV,EV) to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*AV*Z results in a quasi-triangular form +C and Q'*EV*Z results upper triangular. +C Total workspace needed: 2*NV*NV + 11*NV + 16. +C + STDOM = 'U' + EVTYPE = 'G' + ALPHA = ALPHA - SQRT( TOLINF ) + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NV, AV, LDAV, EV, LDEV, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of generalized +C eigenvalues of the pair (AV,EV). +C + CALL AB09JX( DICO, STDOM, EVTYPE, NV, ALPHA, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Compute Q'*BV and CV*Z. +C Total workspace needed: 2*NV*NV + NV*MAX(P,PV). +C + KW = KAR + CALL DLACPY( 'Full', NV, P, BV, LDBV, DWORK(KW), LDW ) + CALL DGEMM( 'T', 'N', NV, P, NV, ONE, DWORK(KQ), LDW, + $ DWORK(KW), LDW, ZERO, BV, LDBV ) + CALL DLACPY( 'Full', PV, NV, CV, LDCV, DWORK(KW), PV ) + CALL DGEMM( 'N', 'N', PV, NV, NV, ONE, DWORK(KW), PV, + $ DWORK(KZ), LDW, ZERO, CV, LDCV ) + END IF + WORK = MAX( WORK, DBLE( 2*NV*NV + NV*MAX( P, PV ) ) ) +C + END IF +C + KC = 1 + KF = KC + NV*N + KE = KF + NV*N + KW = KE + N*N + CALL DLASET( 'Full', NV, N, ZERO, ZERO, DWORK(KF), LDW ) +C + IF( CONJS ) THEN +C +C Compute the projection of conj(V)*G. +C +C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) +C +C Compute CV'*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'T', 'N', NV, N, P, ONE, CV, LDCV, C, LDC, + $ ZERO, DWORK(KC), LDW ) +C + IF( DISCR ) THEN +C +C Compute X and SCALE satisfying +C +C EV'*X - AV'*X*A = SCALE*CV'*C by solving equivalently +C +C EV'*X - Y*A = SCALE*CV'*C, +C AV'*X - Y = 0. +C +C Additional workspace needed: +C real NV*N + N*N; +C integer NV+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN + $ ) + CALL DTGSYL( 'N', 0, NV, N, EV, LDEV, A, LDA, + $ DWORK(KC), LDW, AV, LDAV, DWORK(KE), + $ LDWN, DWORK(KF), LDW, SCALE, DIF, + $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct C <- DV'*C + BV'*X*A/SCALE, +C D <- DV'*D + BV'*X*B/SCALE. +C +C Additional workspace needed: MAX( PV*N, PV*M ). +C +C C <- DV'*C. +C + KW = KF + CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) +C +C D <- DV'*D. +C + CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) +C +C C <- C + BV'*X*A/SCALE. +C + CALL DGEMM( 'T', 'N', PV, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK(KC), LDW, ZERO, DWORK(KW), PV ) + CALL DGEMM( 'N', 'N', PV, N, N, ONE, DWORK(KW), PV, + $ A, LDA, ONE, C, LDC ) +C +C D <- D + BV'*X*B/SCALE. +C + CALL DGEMM( 'N', 'N', PV, M, N, ONE, DWORK(KW), PV, + $ B, LDB, ONE, D, LDD ) + ELSE +C +C Compute X and SCALE satisfying +C +C AV'*X + EV'*X*A + SCALE*CV'*C = 0 by solving equivalently +C +C AV'*X - Y*A = -SCALE*CV'*C, +C EV'*X - Y*(-I) = 0. +C +C Additional workspace needed: +C real NV*N+N*N; +C integer NV+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN + $ ) + CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, + $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), + $ LDWN, DWORK(KF), LDW, SCALE, DIF, + $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) +C +C Note that the computed solution in DWORK(KC) is -X. +C + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct C <- DV'*C + BV'*X/SCALE. +C + KW = KF + CALL DGEMM( 'T', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) + CALL DGEMM( 'T', 'N', PV, N, NV, -ONE / SCALE, BV, LDBV, + $ DWORK(KC), LDW, ONE, C, LDC ) +C +C Construct D <- DV'*D. +C + CALL DGEMM( 'T', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) + END IF + ELSE +C +C Compute the projection of V*G. +C +C Total workspace needed: NV*N + MAX( NV*N+N*N, PV*N, PV*M ) +C +C Compute -BV*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, + $ ZERO, DWORK, LDW ) +C +C Compute X and SCALE satisfying +C +C AV*X - EV*X*A + SCALE*BV*C = 0 by solving equivalently +C +C AV*X - Y*A = -SCALE*BV*C, +C EV*X - Y = 0. +C +C Additional workspace needed: +C real NV*N + N*N; +C integer NV+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) + CALL DTGSYL( 'N', 0, NV, N, AV, LDAV, A, LDA, + $ DWORK(KC), LDW, EV, LDEV, DWORK(KE), LDWN, + $ DWORK(KF), LDW, SCALE, DIF, DWORK(KW), + $ LDWORK-KW+1, IWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct C <- DV*C + CV*X/SCALE. +C + KW = KF + CALL DGEMM( 'N', 'N', PV, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, N, DWORK(KW), PV, C, LDC ) + CALL DGEMM( 'N', 'N', PV, N, NV, ONE / SCALE, CV, LDCV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV*D. +C + CALL DGEMM( 'N', 'N', PV, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), PV ) + CALL DLACPY( 'Full', PV, M, DWORK(KW), PV, D, LDD ) + END IF + END IF +C + DWORK(1) = MAX( WORK, DBLE( LW ) ) +C + RETURN +C *** Last line of AB09JV *** + END diff --git a/mex/sources/libslicot/AB09JW.f b/mex/sources/libslicot/AB09JW.f new file mode 100644 index 000000000..9c8068428 --- /dev/null +++ b/mex/sources/libslicot/AB09JW.f @@ -0,0 +1,972 @@ + SUBROUTINE AB09JW( JOB, DICO, JOBEW, STBCHK, N, M, P, NW, MW, + $ A, LDA, B, LDB, C, LDC, D, LDD, AW, LDAW, + $ EW, LDEW, BW, LDBW, CW, LDCW, DW, LDDW, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct a state-space representation (A,BS,CS,DS) of the +C projection of G*W or G*conj(W) containing the poles of G, from the +C state-space representations (A,B,C,D) and (AW-lambda*EW,BW,CW,DW), +C of the transfer-function matrices G and W, respectively. +C G is assumed to be a stable transfer-function matrix and +C the state matrix A must be in a real Schur form. +C When computing the stable projection of G*W, it is assumed +C that G and W have completely distinct poles. +C When computing the stable projection of G*conj(W), it is assumed +C that G and conj(W) have completely distinct poles. +C +C Note: For a transfer-function matrix G, conj(G) denotes the +C conjugate of G given by G'(-s) for a continuous-time system or +C G'(1/z) for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the projection to be computed as follows: +C = 'W': compute the projection of G*W containing +C the poles of G; +C = 'C': compute the projection of G*conj(W) containing +C the poles of G. +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G and W are continuous-time systems; +C = 'D': G and W are discrete-time systems. +C +C JOBEW CHARACTER*1 +C Specifies whether EW is a general square or an identity +C matrix as follows: +C = 'G': EW is a general square matrix; +C = 'I': EW is the identity matrix. +C +C STBCHK CHARACTER*1 +C Specifies whether stability/antistability of W is to be +C checked as follows: +C = 'C': check stability if JOB = 'C' or antistability if +C JOB = 'W'; +C = 'N': do not check stability or antistability. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector of the system with +C the transfer-function matrix G. N >= 0. +C +C M (input) INTEGER +C The dimension of the input vector of the system with +C the transfer-function matrix G, and also the dimension +C of the output vector if JOB = 'W', or of the input vector +C if JOB = 'C', of the system with the transfer-function +C matrix W. M >= 0. +C +C P (input) INTEGER +C The dimension of the output vector of the system with the +C transfer-function matrix G. P >= 0. +C +C NW (input) INTEGER +C The dimension of the state vector of the system with the +C transfer-function matrix W. NW >= 0. +C +C MW (input) INTEGER +C The dimension of the input vector, if JOB = 'W', or of +C the output vector, if JOB = 'C', of the system with the +C transfer-function matrix W. MW >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system with the transfer-function +C matrix G in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, +C dimension (LDB,MAX(M,MW)) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading N-by-MW part of this +C array contains the input matrix BS of the projection of +C G*W, if JOB = 'W', or of G*conj(W), if JOB = 'C'. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain +C the output/state matrix C of the system with the +C transfer-function matrix G. The matrix CS is equal to C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, +C dimension (LDB,MAX(M,MW)) +C On entry, the leading P-by-M part of this array must +C contain the feedthrough matrix D of the system with +C the transfer-function matrix G. +C On exit, if INFO = 0, the leading P-by-MW part of +C this array contains the feedthrough matrix DS of the +C projection of G*W, if JOB = 'W', or of G*conj(W), +C if JOB = 'C'. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,P). +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, the leading NW-by-NW part of this array must +C contain the state matrix AW of the system with the +C transfer-function matrix W. +C On exit, if INFO = 0, the leading NW-by-NW part of this +C array contains a condensed matrix as follows: +C if JOBEW = 'I', it contains the real Schur form of AW; +C if JOBEW = 'G' and JOB = 'W', it contains a quasi-upper +C triangular matrix representing the real Schur matrix +C in the real generalized Schur form of the pair (AW,EW); +C if JOBEW = 'G', JOB = 'C' and DICO = 'C', it contains a +C quasi-upper triangular matrix corresponding to the +C generalized real Schur form of the pair (AW',EW'); +C if JOBEW = 'G', JOB = 'C' and DICO = 'D', it contains an +C upper triangular matrix corresponding to the generalized +C real Schur form of the pair (EW',AW'). +C +C LDAW INTEGER +C The leading dimension of the array AW. LDAW >= MAX(1,NW). +C +C EW (input/output) DOUBLE PRECISION array, dimension (LDEW,NW) +C On entry, if JOBEW = 'G', the leading NW-by-NW part of +C this array must contain the descriptor matrix EW of the +C system with the transfer-function matrix W. +C If JOBEW = 'I', EW is assumed to be an identity matrix +C and is not referenced. +C On exit, if INFO = 0 and JOBEW = 'G', the leading NW-by-NW +C part of this array contains a condensed matrix as follows: +C if JOB = 'W', it contains an upper triangular matrix +C corresponding to the real generalized Schur form of the +C pair (AW,EW); +C if JOB = 'C' and DICO = 'C', it contains an upper +C triangular matrix corresponding to the generalized real +C Schur form of the pair (AW',EW'); +C if JOB = 'C' and DICO = 'D', it contains a quasi-upper +C triangular matrix corresponding to the generalized +C real Schur form of the pair (EW',AW'). +C +C LDEW INTEGER +C The leading dimension of the array EW. +C LDEW >= MAX(1,NW), if JOBEW = 'G'; +C LDEW >= 1, if JOBEW = 'I'. +C +C BW (input/output) DOUBLE PRECISION array, +C dimension (LDBW,MBW), where MBW = MW, if JOB = 'W', and +C MBW = M, if JOB = 'C'. +C On entry, the leading NW-by-MBW part of this array must +C contain the input matrix BW of the system with the +C transfer-function matrix W. +C On exit, if INFO = 0, the leading NW-by-MBW part of this +C array contains Q'*BW, where Q is the orthogonal matrix +C that reduces AW to the real Schur form or the left +C orthogonal matrix used to reduce the pair (AW,EW), +C (AW',EW') or (EW',AW') to the generalized real Schur form. +C +C LDBW INTEGER +C The leading dimension of the array BW. LDBW >= MAX(1,NW). +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, the leading PCW-by-NW part of this array must +C contain the output matrix CW of the system with the +C transfer-function matrix W, where PCW = M if JOB = 'W' or +C PCW = MW if JOB = 'C'. +C On exit, if INFO = 0, the leading PCW-by-NW part of this +C array contains CW*Q, where Q is the orthogonal matrix that +C reduces AW to the real Schur form, or CW*Z, where Z is the +C right orthogonal matrix used to reduce the pair (AW,EW), +C (AW',EW') or (EW',AW') to the generalized real Schur form. +C +C LDCW INTEGER +C The leading dimension of the array CW. +C LDCW >= MAX(1,PCW), where PCW = M if JOB = 'W', or +C PCW = MW if JOB = 'C'. +C +C DW (input) DOUBLE PRECISION array, +C dimension (LDDW,MBW), where MBW = MW if JOB = 'W', and +C MBW = M if JOB = 'C'. +C The leading PCW-by-MBW part of this array must contain +C the feedthrough matrix DW of the system with the +C transfer-function matrix W, where PCW = M if JOB = 'W', +C or PCW = MW if JOB = 'C'. +C +C LDDW INTEGER +C LDDW >= MAX(1,PCW), where PCW = M if JOB = 'W', or +C PCW = MW if JOB = 'C'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOBEW = 'I'; +C LIWORK = NW+N+6, if JOBEW = 'G'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= LW1, if JOBEW = 'I', +C LDWORK >= LW2, if JOBEW = 'G', where +C LW1 = MAX( 1, NW*(NW+5), NW*N + MAX( a, N*MW, P*MW ) ) +C a = 0, if DICO = 'C' or JOB = 'W', +C a = 2*NW, if DICO = 'D' and JOB = 'C'; +C LW2 = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), +C NW*N + MAX( NW*N+N*N, MW*N, P*MW ) ). +C For good performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of the pair (AW,EW) to the real +C generalized Schur form failed (JOBEW = 'G'), +C or the reduction of the matrix AW to the real +C Schur form failed (JOBEW = 'I); +C = 2: the solution of the Sylvester equation failed +C because the matrix A and the pencil AW-lambda*EW +C have common eigenvalues (if JOB = 'W'), or the +C pencil -AW-lambda*EW and A have common eigenvalues +C (if JOB = 'C' and DICO = 'C'), or the pencil +C AW-lambda*EW has an eigenvalue which is the +C reciprocal of one of eigenvalues of A +C (if JOB = 'C' and DICO = 'D'); +C = 3: the solution of the Sylvester equation failed +C because the matrices A and AW have common +C eigenvalues (if JOB = 'W'), or the matrices A +C and -AW have common eigenvalues (if JOB = 'C' and +C DICO = 'C'), or the matrix A has an eigenvalue +C which is the reciprocal of one of eigenvalues of AW +C (if JOB = 'C' and DICO = 'D'); +C = 4: JOB = 'W' and the pair (AW,EW) has not completely +C unstable generalized eigenvalues, or JOB = 'C' and +C the pair (AW,EW) has not completely stable +C generalized eigenvalues. +C +C METHOD +C +C If JOB = 'W', the matrices of the stable projection of G*W are +C computed as +C +C BS = B*DW + Y*BW, CS = C, DS = D*DW, +C +C where Y satisfies the generalized Sylvester equation +C +C -A*Y*EW + Y*AW + B*CW = 0. +C +C If JOB = 'C', the matrices of the stable projection of G*conj(W) +C are computed using the following formulas: +C +C - for a continuous-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B*DW' + Y*CW', CS = C, DS = D*DW', +C +C where Y satisfies the generalized Sylvester equation +C +C A*Y*EW' + Y*AW' + B*BW' = 0. +C +C - for a discrete-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B*DW' + A*Y*CW', CS = C, DS = D*DW' + C*Y*CW', +C +C where Y satisfies the generalized Sylvester equation +C +C Y*EW' - A*Y*AW' = B*BW'. +C +C REFERENCES +C +C [1] Varga, A. +C Efficient and numerically reliable implementation of the +C frequency-weighted Hankel-norm approximation model reduction +C approach. +C Proc. 2001 ECC, Porto, Portugal, 2001. +C +C [2] Zhou, K. +C Frequency-weighted H-infinity norm and optimal Hankel norm +C model reduction. +C IEEE Trans. Autom. Control, vol. 40, pp. 1687-1699, 1995. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on numerically stable algorithms. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. +C D. Sima, University of Bucharest, March 2001. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, JOBEW, STBCHK + INTEGER INFO, LDA, LDAW, LDB, LDBW, LDC, LDCW, + $ LDD, LDDW, LDEW, LDWORK, M, MW, N, NW, P +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AW(LDAW,*), B(LDB,*), BW(LDBW,*), + $ C(LDC,*), CW(LDCW,*), D(LDD,*), DW(LDDW,*), + $ DWORK(*), EW(LDEW,*) +C .. Local Scalars .. + CHARACTER*1 EVTYPE, STDOM + LOGICAL CONJS, DISCR, STABCK, UNITEW + DOUBLE PRECISION ALPHA, DIF, SCALE, TOLINF, WORK + INTEGER I, IA, IERR, KAI, KAR, KB, KC, KE, KF, KQ, KW, + $ KZ, LDW, LDWM, LDWN, LDWP, LW, SDIM +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL DELCTG, LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DELCTG, DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL AB09JX, DGEMM, DGGES, DLACPY, DLASET, DSWAP, + $ DTGSYL, DTRSYL, SB04PY, TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +C +C .. Executable Statements .. +C + CONJS = LSAME( JOB, 'C' ) + DISCR = LSAME( DICO, 'D' ) + UNITEW = LSAME( JOBEW, 'I' ) + STABCK = LSAME( STBCHK, 'C' ) +C + INFO = 0 + IF( UNITEW ) THEN + IF ( DISCR .AND. CONJS ) THEN + IA = 2*NW + ELSE + IA = 0 + END IF + LW = MAX( 1, NW*( NW + 5 ), NW*N + MAX( IA, N*MW, P*MW ) ) + ELSE + LW = MAX( 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ), + $ NW*N + MAX( NW*N + N*N, MW*N, P*MW ) ) + END IF +C +C Test the input scalar arguments. +C + LDW = MAX( 1, NW ) + LDWM = MAX( 1, MW ) + LDWN = MAX( 1, N ) + LDWP = MAX( 1, P ) + IF( .NOT. ( LSAME( JOB, 'W' ) .OR. CONJS ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBEW, 'G' ) .OR. UNITEW ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( STBCHK, 'N' ) .OR. STABCK ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( NW.LT.0 ) THEN + INFO = -8 + ELSE IF( MW.LT.0 ) THEN + INFO = -9 + ELSE IF( LDA.LT.LDWN ) THEN + INFO = -11 + ELSE IF( LDB.LT.LDWN ) THEN + INFO = -13 + ELSE IF( LDC.LT.LDWP ) THEN + INFO = -15 + ELSE IF( LDD.LT.LDWP ) THEN + INFO = -17 + ELSE IF( LDAW.LT.LDW ) THEN + INFO = -19 + ELSE IF( LDEW.LT.1 .OR. ( .NOT.UNITEW .AND. LDEW.LT.NW ) ) THEN + INFO = -21 + ELSE IF( LDBW.LT.LDW ) THEN + INFO = -23 + ELSE IF( ( .NOT.CONJS .AND. LDCW.LT.MAX( 1, M ) ) .OR. + $ ( CONJS .AND. LDCW.LT.LDWM ) ) THEN + INFO = -25 + ELSE IF( ( .NOT.CONJS .AND. LDDW.LT.MAX( 1, M ) ) .OR. + $ ( CONJS .AND. LDDW.LT.LDWM ) ) THEN + INFO = -27 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -30 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09JW', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 ) THEN + CALL DLASET( 'Full', N, MW, ZERO, ZERO, B, LDB ) + CALL DLASET( 'Full', P, MW, ZERO, ZERO, D, LDD ) + DWORK(1) = ONE + RETURN + END IF +C +C Set options for stability/antistability checking. +C + IF( DISCR ) THEN + ALPHA = ONE + ELSE + ALPHA = ZERO + END IF +C + WORK = ONE + TOLINF = DLAMCH( 'Epsilon' ) +C + IF( UNITEW ) THEN +C +C EW is the identity matrix. +C + IF( NW.GT.0 ) THEN +C +C Reduce AW to the real Schur form using an orthogonal +C similarity transformation AW <- Q'*AW*Q and apply the +C transformation to BW and CW: BW <- Q'*BW and CW <- CW*Q. +C +C Workspace needed: NW*(NW+5); +C prefer larger. +C + KW = NW*( NW + 2 ) + 1 + IF( CONJS ) THEN + STDOM = 'S' + ALPHA = ALPHA + SQRT( TOLINF ) + CALL TB01WD( NW, M, MW, AW, LDAW, BW, LDBW, CW, LDCW, + $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), + $ DWORK(KW), LDWORK-KW+1, IERR ) + ELSE + STDOM = 'U' + ALPHA = ALPHA - SQRT( TOLINF ) + CALL TB01WD( NW, MW, M, AW, LDAW, BW, LDBW, CW, LDCW, + $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), + $ DWORK(KW), LDWORK-KW+1, IERR ) + END IF + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of eigenvalues of AV. +C + CALL AB09JX( DICO, STDOM, 'S', NW, ALPHA, DWORK, + $ DWORK(NW+1), DWORK, TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF +C + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C + END IF +C + KW = NW*N + 1 + IF( CONJS ) THEN +C +C Compute the projection of G*conj(W). +C +C Total workspace needed: NW*N + MAX( a, N*MW, P*MW ), where +C a = 0, if DICO = 'C', +C a = 2*NW, if DICO = 'D'. +C +C Compute -BW*B'. +C Workspace needed: NW*N. +C + CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, + $ ZERO, DWORK, LDW ) +C + IF( DISCR ) THEN +C +C Compute Y' and SCALE satisfying +C +C AW*Y'*A' - Y' = -SCALE*BW*B'. +C +C Additional workspace needed: 2*NW. +C + CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, + $ DWORK, LDW, SCALE, DWORK(KW), IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct BS = B*DW' + A*Y*CW'/SCALE, +C DS = D*DW' + C*Y*CW'/SCALE. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C +C B <- B*DW'. +C + CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) +C +C B <- B + A*Y*CW'/SCALE. +C + CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, + $ CW, LDCW, ZERO, DWORK(KW), LDWN ) + CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, + $ DWORK(KW), LDWN, ONE, B, LDB ) +C +C D <- D + C*Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, + $ DWORK(KW), LDWN, ONE, D, LDD ) + ELSE +C +C Compute Y' and SCALE satisfying +C +C AW*Y' + Y'*A' + SCALE*BW*B' = 0. +C + IF( N.GT.0 ) THEN + CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + END IF +C +C Construct BS = B*DW' + Y*CW'/SCALE, +C DS = D*DW'. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C +C Construct B <- B*DW' + Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'T', 'T', N, MW, NW, ONE / SCALE, DWORK, LDW, + $ CW, LDCW, ONE, B, LDB) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) + END IF + ELSE +C +C Compute the projection of G*W. +C +C Total workspace needed: NW*N + MAX( N*MW, P*MW ). +C +C Compute B*CW. +C Workspace needed: N*NW. +C + CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, + $ ZERO, DWORK, LDWN ) +C +C Compute Y and SCALE satisfying +C +C A*Y - Y*AW - SCALE*B*CW = 0. +C + IF( N.GT.0 ) THEN + CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, + $ DWORK, LDWN, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + END IF +C +C Construct BS = B*DW + Y*BW/SCALE, +C DS = D*DW. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C Construct B <- B*DW + Y*BW/SCALE. +C + CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, DWORK, LDWN, + $ BW, LDBW, ONE, B, LDB) +C +C D <- D*DW. +C + CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) + END IF + ELSE +C +C EW is a general matrix. +C + IF( NW.GT.0 ) THEN + TOLINF = TOLINF * DLANGE( '1', NW, NW, EW, LDEW, DWORK ) +C +C Reduce (AW,EW), or (AW',EW') or (EW',AW') to a generalized +C real Schur form using an orthogonal equivalence +C transformation and apply the orthogonal transformation +C appropriately to BW and CW, or CW' and BW'. +C +C Workspace needed: 2*NW*NW + MAX( 11*NW+16, NW*M, MW*NW ); +C prefer larger. +C + KQ = 1 + KZ = KQ + NW*NW + KAR = KZ + NW*NW + KAI = KAR + NW + KB = KAI + NW + KW = KB + NW +C + IF( CONJS ) THEN + STDOM = 'S' + ALPHA = ALPHA + SQRT( TOLINF ) +C +C Transpose AW and EW, if non-scalar. +C + DO 10 I = 1, NW - 1 + CALL DSWAP( NW-I, AW(I+1,I), 1, AW(I,I+1), LDAW ) + CALL DSWAP( NW-I, EW(I+1,I), 1, EW(I,I+1), LDEW ) + 10 CONTINUE +C + IF( DISCR ) THEN +C +C Reduce (EW',AW') to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*EW'*Z results in a quasi-triangular form +C and Q'*AW'*Z results upper triangular. +C Total workspace needed: 2*NW*NW + 11*NW + 16. +C + EVTYPE = 'R' + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NW, EW, LDEW, AW, LDAW, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + ELSE +C +C Reduce (AW',EW') to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*AW'*Z results in a quasi-triangular form +C and Q'*EW'*Z results upper triangular. +C Total workspace needed: 2*NW*NW + 11*NW + 16. +C + EVTYPE = 'G' + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + END IF + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of generalized +C eigenvalues of the pair (AV,EV). +C + CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Compute Z'*BW and CW*Q. +C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). +C + KW = KAR + CALL DLACPY( 'Full', NW, M, BW, LDBW, DWORK(KW), LDW ) + CALL DGEMM( 'T', 'N', NW, M, NW, ONE, DWORK(KZ), LDW, + $ DWORK(KW), LDW, ZERO, BW, LDBW ) + CALL DLACPY( 'Full', MW, NW, CW, LDCW, DWORK(KW), LDWM ) + CALL DGEMM( 'N', 'N', MW, NW, NW, ONE, DWORK(KW), LDWM, + $ DWORK(KQ), LDW, ZERO, CW, LDCW ) + ELSE +C +C Reduce (AW,EW) to a generalized real Schur form +C using orthogonal transformation matrices Q and Z +C such that Q'*AW*Z results in a quasi-triangular form +C and Q'*EW*Z results upper triangular. +C Total workspace needed: 2*NW*NW + 11*NW + 16. +C + STDOM = 'U' + EVTYPE = 'G' + ALPHA = ALPHA - SQRT( TOLINF ) + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', + $ DELCTG, NW, AW, LDAW, EW, LDEW, SDIM, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ DWORK(KQ), LDW, DWORK(KZ), LDW, + $ DWORK(KW), LDWORK-KW+1, BWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IF( STABCK ) THEN +C +C Check stability/antistability of generalized +C eigenvalues of the pair (AV,EV). +C + CALL AB09JX( DICO, STDOM, EVTYPE, NW, ALPHA, + $ DWORK(KAR), DWORK(KAI), DWORK(KB), + $ TOLINF, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C +C Compute Q'*BW and CW*Z. +C Total workspace needed: 2*NW*NW + NW*MAX(M,MW). +C + KW = KAR + CALL DLACPY( 'Full', NW, MW, BW, LDBW, DWORK(KW), LDW ) + CALL DGEMM( 'T', 'N', NW, MW, NW, ONE, DWORK(KQ), LDW, + $ DWORK(KW), LDW, ZERO, BW, LDBW ) + CALL DLACPY( 'Full', M, NW, CW, LDCW, DWORK(KW), M ) + CALL DGEMM( 'N', 'N', M, NW, NW, ONE, DWORK(KW), M, + $ DWORK(KZ), LDW, ZERO, CW, LDCW ) + END IF + WORK = MAX( WORK, DBLE( 2*NW*NW + NW*MAX( M, MW ) ) ) +C + END IF +C + KC = 1 + KF = KC + NW*N + KE = KF + NW*N + KW = KE + N*N + CALL DLASET( 'Full', N, NW, ZERO, ZERO, DWORK(KF), LDWN ) +C + IF( CONJS ) THEN +C +C Compute the projection of G*conj(W). +C +C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) +C +C Compute B*BW'. +C Workspace needed: N*NW. +C + CALL DGEMM( 'N', 'T', N, NW, M, ONE, B, LDB, BW, LDBW, + $ ZERO, DWORK(KC), LDWN ) +C + IF( DISCR ) THEN +C +C Compute Y and SCALE satisfying +C +C Y*EW' - A*Y*AW' = SCALE*B*BW' by solving equivalently +C +C A*X - Y*EW' = -SCALE*B*BW', +C X - Y*AW' = 0. +C +C Additional workspace needed: +C real N*NW + N*N; +C integer NW+N+6. +C +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN + $ ) + CALL DTGSYL( 'N', 0, N, NW, A, LDA, EW, LDEW, + $ DWORK(KC), LDWN, DWORK(KE), LDWN, AW, + $ LDAW, DWORK(KF), LDWN, SCALE, DIF, + $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) +C +C Note that the computed solution in DWORK(KC) is -Y. +C + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct BS = B*DW' + A*Y*CW'/SCALE, +C DS = D*DW' + C*Y*CW'/SCALE. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C +C B <- B*DW'. +C + CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) +C +C B <- B + A*Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'T', N, MW, NW, -ONE / SCALE, + $ DWORK(KF), LDWN, CW, LDCW, ZERO, + $ DWORK(KW), LDWN ) + CALL DGEMM( 'N', 'N', N, MW, N, ONE, A, LDA, + $ DWORK(KW), LDWN, ONE, B, LDB ) +C +C D <- D + C*Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'N', P, MW, N, ONE, C, LDC, + $ DWORK(KW), LDWN, ONE, D, LDD ) + ELSE +C +C Compute Y and SCALE satisfying +C +C A*Y*EW' + Y*AW' + SCALE*B*BW' = 0 by solving equivalently +C +C A*X - Y*AW' = SCALE*B*BW', +C (-I)*X - Y*EW' = 0. +C +C Additional workspace needed: +C real N*NW+N*N; +C integer NW+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, -ONE, DWORK(KE), LDWN + $ ) + CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, + $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, + $ LDEW, DWORK(KF), LDWN, SCALE, DIF, + $ DWORK(KW), LDWORK-KW+1, IWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct BS = B*DW' + Y*CW'/SCALE, +C DS = D*DW'. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C +C Construct B <- B*DW' + Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'T', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'N', 'T', N, MW, NW, ONE / SCALE, + $ DWORK(KF), LDWN, CW, LDCW, ONE, B, LDB ) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) + END IF + ELSE +C +C Compute the projection of G*W. +C +C Total workspace needed: NW*N + MAX( NW*N+N*N, MW*N, P*MW ) +C +C Compute B*CW. +C Workspace needed: N*NW. +C + CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, + $ ZERO, DWORK(KC), LDWN ) +C +C Compute Y and SCALE satisfying +C +C -A*Y*EW + Y*AW + B*CW = 0 by solving equivalently +C +C A*X - Y*AW = SCALE*B*CW, +C X - Y*EW = 0. +C +C Additional workspace needed: +C real N*NW + N*N; +C integer NW+N+6. +C + IF( N.GT.0 ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(KE), LDWN ) + CALL DTGSYL( 'N', 0, N, NW, A, LDA, AW, LDAW, + $ DWORK(KC), LDWN, DWORK(KE), LDWN, EW, LDEW, + $ DWORK(KF), LDWN, SCALE, DIF, DWORK(KW), + $ LDWORK-KW+1, IWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Construct BS = B*DW + Y*BW/SCALE, +C DS = D*DW. +C +C Additional workspace needed: MAX( N*MW, P*MW ). +C Construct B <- B*DW + Y*BW/SCALE. +C + CALL DGEMM( 'N', 'N', N, MW, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'Full', N, MW, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'N', 'N', N, MW, NW, ONE / SCALE, + $ DWORK(KF), LDWN, BW, LDBW, ONE, B, LDB) +C +C D <- D*DW. +C + CALL DGEMM( 'N', 'N', P, MW, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), LDWP ) + CALL DLACPY( 'Full', P, MW, DWORK(KW), LDWP, D, LDD ) + END IF + END IF +C + DWORK(1) = MAX( WORK, DBLE( LW ) ) +C + RETURN +C *** Last line of AB09JW *** + END diff --git a/mex/sources/libslicot/AB09JX.f b/mex/sources/libslicot/AB09JX.f new file mode 100644 index 000000000..68e2c60dd --- /dev/null +++ b/mex/sources/libslicot/AB09JX.f @@ -0,0 +1,253 @@ + SUBROUTINE AB09JX( DICO, STDOM, EVTYPE, N, ALPHA, ER, EI, ED, + $ TOLINF, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To check stability/antistability of finite eigenvalues with +C respect to a given stability domain. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the stability domain as follows: +C = 'C': for a continuous-time system; +C = 'D': for a discrete-time system. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C EVTYPE CHARACTER*1 +C Specifies whether the eigenvalues arise from a standard +C or a generalized eigenvalue problem as follows: +C = 'S': standard eigenvalue problem; +C = 'G': generalized eigenvalue problem; +C = 'R': reciprocal generalized eigenvalue problem. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of vectors ER, EI and ED. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the boundary of the domain of interest for the +C eigenvalues. For a continuous-time system +C (DICO = 'C'), ALPHA is the boundary value for the real +C parts of eigenvalues, while for a discrete-time system +C (DICO = 'D'), ALPHA >= 0 represents the boundary value for +C the moduli of eigenvalues. +C +C ER, EI, (input) DOUBLE PRECISION arrays, dimension (N) +C ED If EVTYPE = 'S', ER(j) + EI(j)*i, j = 1,...,N, are +C the eigenvalues of a real matrix. +C ED is not referenced and is implicitly considered as +C a vector having all elements equal to one. +C If EVTYPE = 'G' or EVTYPE = 'R', (ER(j) + EI(j)*i)/ED(j), +C j = 1,...,N, are the generalized eigenvalues of a pair of +C real matrices. If ED(j) is zero, then the j-th generalized +C eigenvalue is infinite. +C Complex conjugate pairs of eigenvalues must appear +C consecutively. +C +C Tolerances +C +C TOLINF DOUBLE PRECISION +C If EVTYPE = 'G' or 'R', TOLINF contains the tolerance for +C detecting infinite generalized eigenvalues. +C 0 <= TOLINF < 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit, i.e., all eigenvalues lie within +C the domain of interest defined by DICO, STDOM +C and ALPHA; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: some eigenvalues lie outside the domain of interest +C defined by DICO, STDOM and ALPHA. +C METHOD +C +C The domain of interest for an eigenvalue lambda is defined by the +C parameters ALPHA, DICO and STDOM as follows: +C - for a continuous-time system (DICO = 'C'): +C Real(lambda) < ALPHA if STDOM = 'S'; +C Real(lambda) > ALPHA if STDOM = 'U'; +C - for a discrete-time system (DICO = 'D'): +C Abs(lambda) < ALPHA if STDOM = 'S'; +C Abs(lambda) > ALPHA if STDOM = 'U'. +C If EVTYPE = 'R', the same conditions apply for 1/lambda. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C +C KEYWORDS +C +C Stability. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EVTYPE, STDOM + INTEGER INFO, N + DOUBLE PRECISION ALPHA, TOLINF +C .. Array Arguments .. + DOUBLE PRECISION ED(*), EI(*), ER(*) +C .. Local Scalars + LOGICAL DISCR, RECEVP, STAB, STDEVP + DOUBLE PRECISION ABSEV, RPEV, SCALE + INTEGER I +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + STAB = LSAME( STDOM, 'S' ) + STDEVP = LSAME( EVTYPE, 'S' ) + RECEVP = LSAME( EVTYPE, 'R' ) +C +C Check the scalar input arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( STAB .OR. LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( STDEVP .OR. LSAME( EVTYPE, 'G' ) .OR. + $ RECEVP ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -5 + ELSE IF( TOLINF.LT.ZERO .OR. TOLINF.GE.ONE ) THEN + INFO = -9 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09JX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + IF( STAB ) THEN +C +C Check the stability of finite eigenvalues. +C + SCALE = ONE + IF( DISCR ) THEN + DO 10 I = 1, N + ABSEV = DLAPY2( ER(I), EI(I) ) + IF( RECEVP ) THEN + SCALE = ABSEV + ABSEV = ABS( ED(I) ) + ELSE IF( .NOT.STDEVP ) THEN + SCALE = ED(I) + END IF + IF( ABS( SCALE ).GT.TOLINF .AND. + $ ABSEV.GE.ALPHA*SCALE ) THEN + INFO = 1 + RETURN + END IF + 10 CONTINUE + ELSE + DO 20 I = 1, N + RPEV = ER(I) + IF( RECEVP ) THEN + SCALE = RPEV + RPEV = ED(I) + ELSE IF( .NOT.STDEVP ) THEN + SCALE = ED(I) + END IF + IF( ABS( SCALE ).GT.TOLINF .AND. + $ RPEV.GE.ALPHA*SCALE ) THEN + INFO = 1 + RETURN + END IF + 20 CONTINUE + END IF + ELSE +C +C Check the anti-stability of finite eigenvalues. +C + IF( DISCR ) THEN + DO 30 I = 1, N + ABSEV = DLAPY2( ER(I), EI(I) ) + IF( RECEVP ) THEN + SCALE = ABSEV + ABSEV = ABS( ED(I) ) + ELSE IF( .NOT.STDEVP ) THEN + SCALE = ED(I) + END IF + IF( ABS( SCALE ).GT.TOLINF .AND. + $ ABSEV.LE.ALPHA*SCALE ) THEN + INFO = 1 + RETURN + END IF + 30 CONTINUE + ELSE + DO 40 I = 1, N + RPEV = ER(I) + IF( RECEVP ) THEN + SCALE = RPEV + RPEV = ED(I) + ELSE IF( .NOT.STDEVP ) THEN + SCALE = ED(I) + END IF + IF( ABS( SCALE ).GT.TOLINF .AND. + $ RPEV.LE.ALPHA*SCALE ) THEN + INFO = 1 + RETURN + END IF + 40 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of AB09JX *** + END diff --git a/mex/sources/libslicot/AB09KD.f b/mex/sources/libslicot/AB09KD.f new file mode 100644 index 000000000..d390cfd6b --- /dev/null +++ b/mex/sources/libslicot/AB09KD.f @@ -0,0 +1,864 @@ + SUBROUTINE AB09KD( JOB, DICO, WEIGHT, EQUIL, ORDSEL, N, NV, NW, M, + $ P, NR, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ NS, HSV, TOL1, TOL2, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using the frequency +C weighted optimal Hankel-norm approximation method. +C The Hankel norm of the weighted error +C +C V*(G-Gr)*W or conj(V)*(G-Gr)*conj(W) +C +C is minimized, where G and Gr are the transfer-function matrices +C of the original and reduced systems, respectively, and V and W +C are the transfer-function matrices of the left and right frequency +C weights, specified by their state space realizations (AV,BV,CV,DV) +C and (AW,BW,CW,DW), respectively. When minimizing the weighted +C error V*(G-Gr)*W, V and W must be antistable transfer-function +C matrices. When minimizing conj(V)*(G-Gr)*conj(W), V and W must be +C stable transfer-function matrices. +C Additionally, V and W must be invertible transfer-function +C matrices, with the feedthrough matrices DV and DW invertible. +C If the original system is unstable, then the frequency weighted +C Hankel-norm approximation is computed only for the +C ALPHA-stable part of the system. +C +C For a transfer-function matrix G, conj(G) denotes the conjugate +C of G given by G'(-s) for a continuous-time system or G'(1/z) +C for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the frequency-weighting problem as follows: +C = 'N': solve min||V*(G-Gr)*W||_H; +C = 'C': solve min||conj(V)*(G-Gr)*conj(W)||_H. +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'L': only left weighting V is used (W = I); +C = 'R': only right weighting W is used (V = I); +C = 'B': both left and right weightings V and W are used. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C NV (input) INTEGER +C The order of the realization of the left frequency +C weighting V, i.e., the order of the matrix AV. NV >= 0. +C +C NW (input) INTEGER +C The order of the realization of the right frequency +C weighting W, i.e., the order of the matrix AW. NW >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of +C the resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU-KR+1),NMIN), where KR is the +C multiplicity of the Hankel singular value HSV(NR-NU+1), +C NR is the desired order on entry, and NMIN is the order +C of a minimal realization of the ALPHA-stable part of the +C given system; NMIN is determined as the number of Hankel +C singular values greater than NS*EPS*HNORM(As,Bs,Cs), where +C EPS is the machine precision (see LAPACK Library Routine +C DLAMCH) and HNORM(As,Bs,Cs) is the Hankel norm of the +C ALPHA-stable part of the weighted system (computed in +C HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the +C reduced order system in a real Schur form. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV +C part of this array must contain the state matrix AV of a +C state space realization of the left frequency weighting V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C NV-by-NV part of this array contains a real Schur form +C of the state matrix of a state space realization of the +C inverse of V. +C AV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDAV INTEGER +C The leading dimension of the array AV. +C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDAV >= 1, if WEIGHT = 'R' or 'N'. +C +C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part +C of this array must contain the input matrix BV of a state +C space realization of the left frequency weighting V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C NV-by-P part of this array contains the input matrix of a +C state space realization of the inverse of V. +C BV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDBV INTEGER +C The leading dimension of the array BV. +C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDBV >= 1, if WEIGHT = 'R' or 'N'. +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part +C of this array must contain the output matrix CV of a state +C space realization of the left frequency weighting V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C P-by-NV part of this array contains the output matrix of a +C state space realization of the inverse of V. +C CV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDCV INTEGER +C The leading dimension of the array CV. +C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; +C LDCV >= 1, if WEIGHT = 'R' or 'N'. +C +C DV (input/output) DOUBLE PRECISION array, dimension (LDDV,P) +C On entry, if WEIGHT = 'L' or 'B', the leading P-by-P part +C of this array must contain the feedthrough matrix DV of a +C state space realization of the left frequency weighting V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C P-by-P part of this array contains the feedthrough matrix +C of a state space realization of the inverse of V. +C DV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDDV INTEGER +C The leading dimension of the array DV. +C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; +C LDDV >= 1, if WEIGHT = 'R' or 'N'. +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW +C part of this array must contain the state matrix AW of +C a state space realization of the right frequency +C weighting W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C NW-by-NW part of this array contains a real Schur form of +C the state matrix of a state space realization of the +C inverse of W. +C AW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDAW INTEGER +C The leading dimension of the array AW. +C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDAW >= 1, if WEIGHT = 'L' or 'N'. +C +C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part +C of this array must contain the input matrix BW of a state +C space realization of the right frequency weighting W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C NW-by-M part of this array contains the input matrix of a +C state space realization of the inverse of W. +C BW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDBW INTEGER +C The leading dimension of the array BW. +C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDBW >= 1, if WEIGHT = 'L' or 'N'. +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part +C of this array must contain the output matrix CW of a state +C space realization of the right frequency weighting W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C M-by-NW part of this array contains the output matrix of a +C state space realization of the inverse of W. +C CW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDCW INTEGER +C The leading dimension of the array CW. +C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDCW >= 1, if WEIGHT = 'L' or 'N'. +C +C DW (input/output) DOUBLE PRECISION array, dimension (LDDW,M) +C On entry, if WEIGHT = 'R' or 'B', the leading M-by-M part +C of this array must contain the feedthrough matrix DW of +C a state space realization of the right frequency +C weighting W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C M-by-M part of this array contains the feedthrough matrix +C of a state space realization of the inverse of W. +C DW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDDW INTEGER +C The leading dimension of the array DW. +C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDDW >= 1, if WEIGHT = 'L' or 'N'. +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of this array contain +C the Hankel singular values, ordered decreasingly, of the +C ALPHA-stable part of the weighted original system. +C HSV(1) is the Hankel norm of the ALPHA-stable weighted +C subsystem. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the +C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the +C Hankel-norm of the ALPHA-stable part of the weighted +C original system (computed in HSV(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = MAX(1,M,c), if DICO = 'C', +C LIWORK = MAX(1,N,M,c), if DICO = 'D', +C where c = 0, if WEIGHT = 'N', +C c = 2*P, if WEIGHT = 'L', +C c = 2*M, if WEIGHT = 'R', +C c = MAX(2*M,2*P), if WEIGHT = 'B'. +C On exit, if INFO = 0, IWORK(1) contains NMIN, the order of +C the computed minimal realization. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( LDW1, LDW2, LDW3, LDW4 ), where +C LDW1 = 0 if WEIGHT = 'R' or 'N' and +C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C if WEIGHT = 'L' or WEIGHT = 'B', +C LDW2 = 0 if WEIGHT = 'L' or 'N' and +C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C if WEIGHT = 'R' or WEIGHT = 'B', with +C a = 0, b = 0, if DICO = 'C' or JOB = 'N', +C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; +C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system; in this case, the resulting NR is set equal +C to NSMIN; +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system; in this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable +C diagonal blocks failed because of very close +C eigenvalues; +C = 3: the reduction of AV or AV-BV*inv(DV)*CV to a +C real Schur form failed; +C = 4: the reduction of AW or AW-BW*inv(DW)*CW to a +C real Schur form failed; +C = 5: JOB = 'N' and AV is not antistable, or +C JOB = 'C' and AV is not stable; +C = 6: JOB = 'N' and AW is not antistable, or +C JOB = 'C' and AW is not stable; +C = 7: the computation of Hankel singular values failed; +C = 8: the computation of stable projection in the +C Hankel-norm approximation algorithm failed; +C = 9: the order of computed stable projection in the +C Hankel-norm approximation algorithm differs +C from the order of Hankel-norm approximation; +C = 10: DV is singular; +C = 11: DW is singular; +C = 12: the solution of the Sylvester equation failed +C because the zeros of V (if JOB = 'N') or of conj(V) +C (if JOB = 'C') are not distinct from the poles +C of G1sr (see METHOD); +C = 13: the solution of the Sylvester equation failed +C because the zeros of W (if JOB = 'N') or of conj(W) +C (if JOB = 'C') are not distinct from the poles +C of G1sr (see METHOD). +C +C METHOD +C +C Let G be the transfer-function matrix of the original +C linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09KD determines +C the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t), (2) +C +C such that the corresponding transfer-function matrix Gr minimizes +C the Hankel-norm of the frequency-weighted error +C +C V*(G-Gr)*W, (3) +C or +C conj(V)*(G-Gr)*conj(W). (4) +C +C For minimizing (3), V and W are assumed to be antistable, while +C for minimizing (4), V and W are assumed to be stable transfer- +C function matrices. +C +C Note: conj(G) = G'(-s) for a continuous-time system and +C conj(G) = G'(1/z) for a discrete-time system. +C +C The following procedure is used to reduce G (see [1]): +C +C 1) Decompose additively G as +C +C G = G1 + G2, +C +C such that G1 = (A1,B1,C1,D) has only ALPHA-stable poles and +C G2 = (A2,B2,C2,0) has only ALPHA-unstable poles. +C +C 2) Compute G1s, the stable projection of V*G1*W or +C conj(V)*G1*conj(W), using explicit formulas [4]. +C +C 3) Determine G1sr, the optimal Hankel-norm approximation of G1s +C of order r. +C +C 4) Compute G1r, the stable projection of either inv(V)*G1sr*inv(W) +C or conj(inv(V))*G1sr*conj(inv(W)), using explicit formulas [4]. +C +C 5) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the weighted ALPHA-stable part G1s at step 3, the +C optimal Hankel-norm approximation method of [2], based on the +C square-root balancing projection formulas of [3], is employed. +C +C The optimal weighted approximation error satisfies +C +C HNORM[V*(G-Gr)*W] = S(r+1), +C or +C HNORM[conj(V)*(G-Gr)*conj(W)] = S(r+1), +C +C where S(r+1) is the (r+1)-th Hankel singular value of G1s, the +C transfer-function matrix computed at step 2 of the above +C procedure, and HNORM(.) denotes the Hankel-norm. +C +C REFERENCES +C +C [1] Latham, G.A. and Anderson, B.D.O. +C Frequency-weighted optimal Hankel-norm approximation of stable +C transfer functions. +C Systems & Control Letters, Vol. 5, pp. 229-236, 1985. +C +C [2] Glover, K. +C All optimal Hankel norm approximation of linear +C multivariable systems and their L-infinity error bounds. +C Int. J. Control, Vol. 36, pp. 1145-1193, 1984. +C +C [3] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [4] Varga A. +C Explicit formulas for an efficient implementation +C of the frequency-weighting model reduction approach. +C Proc. 1993 European Control Conference, Groningen, NL, +C pp. 693-696, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on an accuracy enhancing square-root +C technique. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, +C by A. Varga, 1992. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000. +C Oct. 2001, March 2005. +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL, WEIGHT + INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, + $ NR, NS, NV, NW, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AV(LDAV,*), AW(LDAW,*), + $ B(LDB,*), BV(LDBV,*), BW(LDBW,*), + $ C(LDC,*), CV(LDCV,*), CW(LDCW,*), + $ D(LDD,*), DV(LDDV,*), DW(LDDW,*), DWORK(*), + $ HSV(*) +C .. Local Scalars .. + LOGICAL CONJS, DISCR, FIXORD, FRWGHT, LEFTW, RIGHTW + INTEGER IA, IB, IERR, IWARNL, KI, KL, KU, KW, LW, NMIN, + $ NRA, NU, NU1 + DOUBLE PRECISION ALPWRK, MAXRED, RCOND, WRKOPT +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB07ND, AB09CX, AB09KX, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + CONJS = LSAME( JOB, 'C' ) + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) + LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) + RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) + FRWGHT = LEFTW .OR. RIGHTW +C + IF ( DISCR .AND. CONJS ) THEN + IA = 2*NV + IB = 2*NW + ELSE + IA = 0 + IB = 0 + END IF + LW = 1 + IF( LEFTW ) + $ LW = MAX( LW, NV*(NV+5), NV*N + MAX( IA, P*N, P*M ) ) + IF( RIGHTW ) + $ LW = MAX( LW, MAX( NW*(NW+5), NW*N + MAX( IB, M*N, P*M ) ) ) + LW = MAX( LW, N*( 2*N + MAX( N, M, P ) + 5 ) + ( N*( N + 1 ) )/2 ) + LW = MAX( LW, N*( M + P + 2 ) + 2*M*P + MIN( N, M ) + + $ MAX ( 3*M + 1, MIN( N, M ) + P ) ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -2 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( NV.LT.0 ) THEN + INFO = -7 + ELSE IF( NW.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -11 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -12 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -18 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -20 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -22 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -24 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN + INFO = -26 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN + INFO = -28 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -30 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -32 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -34 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -36 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -40 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -43 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09KD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + NS = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + KU = 1 + KL = KU + N*N + KI = KL + N + KW = KI + N +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation, A <- inv(T)*A*T, and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KL), + $ DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Compute the stable projection of the weighted ALPHA-stable part. +C +C Workspace: need MAX( 1, LDW1, LDW2 ), +C LDW1 = 0 if WEIGHT = 'R' or 'N' and +C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C if WEIGHT = 'L' or 'B', +C LDW2 = 0 if WEIGHT = 'L' or 'N' and +C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C if WEIGHT = 'R' or 'B', +C where a = 0, b = 0, if DICO = 'C' or JOB = 'N', +C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'; +C prefer larger. +C + NS = N - NU +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 + IF( FRWGHT ) THEN + CALL AB09KX( JOB, DICO, WEIGHT, NS, NV, NW, M, P, A(NU1,NU1), + $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ DWORK, LDWORK, IWARNL, IERR ) +C + IF( IERR.NE.0 ) THEN +C +C Note: Only IERR = 1 or IERR = 2 are possible. +C Set INFO to 3 or 4. +C + INFO = IERR + 2 + RETURN + END IF +C + IF( IWARNL.NE.0 ) THEN +C +C Stability/antistability of V and W are compulsory. +C + IF( IWARNL.EQ.1 .OR. IWARNL.EQ.3 ) THEN + INFO = 5 + ELSE + INFO = 6 + END IF + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(1) ) + END IF +C +C Determine a reduced order approximation of the ALPHA-stable part. +C +C Workspace: need MAX( LDW3, LDW4 ), +C LDW3 = N*(2*N + MAX(N,M,P) + 5) + N*(N+1)/2, +C LDW4 = N*(M+P+2) + 2*M*P + MIN(N,M) + +C MAX( 3*M+1, MIN(N,M)+P ); +C prefer larger. +C + IWARNL = 0 + IF( FIXORD ) THEN + NRA = MAX( 0, NR - NU ) + IF( NRA.EQ.0 ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF + CALL AB09CX( DICO, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, IERR ) +C + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN +C +C Set INFO = 7, 8 or 9. +C + INFO = IERR + 5 + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) + NMIN = IWORK(1) +C +C Compute the state space realizations of the inverses of V and W. +C +C Integer workspace: need c, +C Real workspace: need MAX(1,2*c), +C where c = 0, if WEIGHT = 'N', +C c = 2*P, if WEIGHT = 'L', +C c = 2*M, if WEIGHT = 'R', +C c = MAX(2*M,2*P), if WEIGHT = 'B'. +C + IF( LEFTW ) THEN + CALL AB07ND( NV, P, AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ RCOND, IWORK, DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 10 + RETURN + END IF + END IF + IF( RIGHTW ) THEN + CALL AB07ND( NW, M, AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ RCOND, IWORK, DWORK, LDWORK, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 11 + RETURN + END IF + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C +C Compute the stable projection of weighted reduced ALPHA-stable +C part. +C + IF( FRWGHT ) THEN + CALL AB09KX( JOB, DICO, WEIGHT, NRA, NV, NW, M, P, A(NU1,NU1), + $ LDA, B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ DWORK, LDWORK, IWARNL, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.LE.2 ) THEN +C +C Set INFO to 3 or 4. +C + INFO = IERR + 2 + ELSE +C +C Set INFO to 12 or 13. +C + INFO = IERR + 9 + END IF + RETURN + END IF + END IF +C + NR = NRA + NU + IWORK(1) = NMIN + DWORK(1) = MAX( WRKOPT, DWORK(1) ) +C + RETURN +C *** Last line of AB09KD *** + END diff --git a/mex/sources/libslicot/AB09KX.f b/mex/sources/libslicot/AB09KX.f new file mode 100644 index 000000000..5ac044c76 --- /dev/null +++ b/mex/sources/libslicot/AB09KX.f @@ -0,0 +1,869 @@ + SUBROUTINE AB09KX( JOB, DICO, WEIGHT, N, NV, NW, M, P, + $ A, LDA, B, LDB, C, LDC, D, LDD, + $ AV, LDAV, BV, LDBV, CV, LDCV, DV, LDDV, + $ AW, LDAW, BW, LDBW, CW, LDCW, DW, LDDW, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct a state-space representation (A,BS,CS,DS) of the +C stable projection of V*G*W or conj(V)*G*conj(W) from the +C state-space representations (A,B,C,D), (AV,BV,CV,DV), and +C (AW,BW,CW,DW) of the transfer-function matrices G, V and W, +C respectively. G is assumed to be a stable transfer-function +C matrix and the state matrix A must be in a real Schur form. +C When computing the stable projection of V*G*W, V and W are assumed +C to be completely unstable transfer-function matrices. +C When computing the stable projection of conj(V)*G*conj(W), +C V and W are assumed to be stable transfer-function matrices. +C +C For a transfer-function matrix G, conj(G) denotes the conjugate +C of G given by G'(-s) for a continuous-time system or G'(1/z) +C for a discrete-time system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies which projection to be computed as follows: +C = 'N': compute the stable projection of V*G*W; +C = 'C': compute the stable projection of +C conj(V)*G*conj(W). +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G, V and W are continuous-time systems; +C = 'D': G, V and W are discrete-time systems. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'L': only left weighting V is used (W = I); +C = 'R': only right weighting W is used (V = I); +C = 'B': both left and right weightings V and W are used. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. Also the number of rows of +C the matrix B and the number of columns of the matrix C. +C N represents the dimension of the state vector of the +C system with the transfer-function matrix G. N >= 0. +C +C NV (input) INTEGER +C The order of the matrix AV. Also the number of rows of +C the matrix BV and the number of columns of the matrix CV. +C NV represents the dimension of the state vector of the +C system with the transfer-function matrix V. NV >= 0. +C +C NW (input) INTEGER +C The order of the matrix AW. Also the number of rows of +C the matrix BW and the number of columns of the matrix CW. +C NW represents the dimension of the state vector of the +C system with the transfer-function matrix W. NW >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B, D, BW and DW +C and number of rows of the matrices CW and DW. M >= 0. +C M represents the dimension of input vectors of the +C systems with the transfer-function matrices G and W and +C also the dimension of the output vector of the system +C with the transfer-function matrix W. +C +C P (input) INTEGER +C The number of rows of the matrices C, D, CV and DV and the +C number of columns of the matrices BV and DV. P >= 0. +C P represents the dimension of output vectors of the +C systems with the transfer-function matrices G and V and +C also the dimension of the input vector of the system +C with the transfer-function matrix V. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must +C contain the state matrix A of the system with the +C transfer-function matrix G in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the input matrix BS of the stable +C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) +C if JOB = 'C'. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading P-by-N part of this +C array contains the output matrix CS of the stable +C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) +C if JOB = 'C'. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the feedthrough matrix D of the system with the +C transfer-function matrix G. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the feedthrough matrix DS of the stable +C projection of V*G*W if JOB = 'N', and of conj(V)*G*conj(W) +C if JOB = 'C'. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,P). +C +C AV (input/output) DOUBLE PRECISION array, dimension (LDAV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-NV +C part of this array must contain the state matrix AV of +C the system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C NV-by-NV part of this array contains a real Schur form +C of AV. +C AV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDAV INTEGER +C The leading dimension of the array AV. +C LDAV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDAV >= 1, if WEIGHT = 'R' or 'N'. +C +C BV (input/output) DOUBLE PRECISION array, dimension (LDBV,P) +C On entry, if WEIGHT = 'L' or 'B', the leading NV-by-P part +C of this array must contain the input matrix BV of the +C system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C NV-by-P part of this array contains the transformed input +C matrix BV. +C BV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDBV INTEGER +C The leading dimension of the array BV. +C LDBV >= MAX(1,NV), if WEIGHT = 'L' or 'B'; +C LDBV >= 1, if WEIGHT = 'R' or 'N'. +C +C CV (input/output) DOUBLE PRECISION array, dimension (LDCV,NV) +C On entry, if WEIGHT = 'L' or 'B', the leading P-by-NV part +C of this array must contain the output matrix CV of the +C system with the transfer-function matrix V. +C On exit, if WEIGHT = 'L' or 'B', and INFO = 0, the leading +C P-by-NV part of this array contains the transformed output +C matrix CV. +C CV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDCV INTEGER +C The leading dimension of the array CV. +C LDCV >= MAX(1,P), if WEIGHT = 'L' or 'B'; +C LDCV >= 1, if WEIGHT = 'R' or 'N'. +C +C DV (input) DOUBLE PRECISION array, dimension (LDDV,P) +C If WEIGHT = 'L' or 'B', the leading P-by-P part of this +C array must contain the feedthrough matrix DV of the system +C with the transfer-function matrix V. +C DV is not referenced if WEIGHT = 'R' or 'N'. +C +C LDDV INTEGER +C The leading dimension of the array DV. +C LDDV >= MAX(1,P), if WEIGHT = 'L' or 'B'; +C LDDV >= 1, if WEIGHT = 'R' or 'N'. +C +C AW (input/output) DOUBLE PRECISION array, dimension (LDAW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-NW +C part of this array must contain the state matrix AW of +C the system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C NW-by-NW part of this array contains a real Schur form +C of AW. +C AW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDAW INTEGER +C The leading dimension of the array AW. +C LDAW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDAW >= 1, if WEIGHT = 'L' or 'N'. +C +C BW (input/output) DOUBLE PRECISION array, dimension (LDBW,M) +C On entry, if WEIGHT = 'R' or 'B', the leading NW-by-M part +C of this array must contain the input matrix BW of the +C system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C NW-by-M part of this array contains the transformed input +C matrix BW. +C BW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDBW INTEGER +C The leading dimension of the array BW. +C LDBW >= MAX(1,NW), if WEIGHT = 'R' or 'B'; +C LDBW >= 1, if WEIGHT = 'L' or 'N'. +C +C CW (input/output) DOUBLE PRECISION array, dimension (LDCW,NW) +C On entry, if WEIGHT = 'R' or 'B', the leading M-by-NW part +C of this array must contain the output matrix CW of the +C system with the transfer-function matrix W. +C On exit, if WEIGHT = 'R' or 'B', and INFO = 0, the leading +C M-by-NW part of this array contains the transformed output +C matrix CW. +C CW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDCW INTEGER +C The leading dimension of the array CW. +C LDCW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDCW >= 1, if WEIGHT = 'L' or 'N'. +C +C DW (input) DOUBLE PRECISION array, dimension (LDDW,M) +C If WEIGHT = 'R' or 'B', the leading M-by-M part of this +C array must contain the feedthrough matrix DW of the system +C with the transfer-function matrix W. +C DW is not referenced if WEIGHT = 'L' or 'N'. +C +C LDDW INTEGER +C The leading dimension of the array DW. +C LDDW >= MAX(1,M), if WEIGHT = 'R' or 'B'; +C LDDW >= 1, if WEIGHT = 'L' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, LDW1, LDW2 ), where +C LDW1 = 0 if WEIGHT = 'R' or 'N' and +C LDW1 = MAX( NV*(NV+5), NV*N + MAX( a, P*N, P*M ) ) +C if WEIGHT = 'L' or WEIGHT = 'B', +C LDW2 = 0 if WEIGHT = 'L' or 'N' and +C LDW2 = MAX( NW*(NW+5), NW*N + MAX( b, M*N, P*M ) ) +C if WEIGHT = 'R' or WEIGHT = 'B', +C a = 0, b = 0, if DICO = 'C' or JOB = 'N', +C a = 2*NV, b = 2*NW, if DICO = 'D' and JOB = 'C'. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: JOB = 'N' and AV is not completely unstable, or +C JOB = 'C' and AV is not stable; +C = 2: JOB = 'N' and AW is not completely unstable, or +C JOB = 'C' and AW is not stable; +C = 3: both above conditions appear. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of AV to a real Schur form failed; +C = 2: the reduction of AW to a real Schur form failed; +C = 3: the solution of the Sylvester equation failed +C because the matrices A and AV have common +C eigenvalues (if JOB = 'N'), or -AV and A have +C common eigenvalues (if JOB = 'C' and DICO = 'C'), +C or AV has an eigenvalue which is the reciprocal of +C one of the eigenvalues of A (if JOB = 'C' and +C DICO = 'D'); +C = 4: the solution of the Sylvester equation failed +C because the matrices A and AW have common +C eigenvalues (if JOB = 'N'), or -AW and A have +C common eigenvalues (if JOB = 'C' and DICO = 'C'), +C or AW has an eigenvalue which is the reciprocal of +C one of the eigenvalues of A (if JOB = 'C' and +C DICO = 'D'). +C +C METHOD +C +C The matrices of the stable projection of V*G*W are computed as +C +C BS = B*DW + Y*BW, CS = CV*X + DV*C, DS = DV*D*DW, +C +C where X and Y satisfy the continuous-time Sylvester equations +C +C AV*X - X*A + BV*C = 0, +C -A*Y + Y*AW + B*CW = 0. +C +C The matrices of the stable projection of conj(V)*G*conj(W) are +C computed using the explicit formulas established in [1]. +C +C For a continuous-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B*DW' + Y*CW', CS = BV'*X + DV'*C, DS = DV'*D*DW', +C +C where X and Y satisfy the continuous-time Sylvester equations +C +C AV'*X + X*A + CV'*C = 0, +C A*Y + Y*AW' + B*BW' = 0. +C +C For a discrete-time system, the matrices BS, CS and DS of +C the stable projection are computed as +C +C BS = B*DW' + A*Y*CW', CS = BV'*X*A + DV'*C, +C DS = DV'*D*DW' + BV'*X*B*DW' + DV'*C*Y*CW' + BV'*X*A*Y*CW', +C +C where X and Y satisfy the discrete-time Sylvester equations +C +C AV'*X*A + CV'*C = X, +C A*Y*AW' + B*BW' = Y. +C +C REFERENCES +C +C [1] Varga A. +C Explicit formulas for an efficient implementation +C of the frequency-weighting model reduction approach. +C Proc. 1993 European Control Conference, Groningen, NL, +C pp. 693-696, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on numerically stable algorithms. +C +C FURTHER COMMENTS +C +C The matrix A must be stable, but its stability is not checked by +C this routine. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, April 2000. +C D. Sima, University of Bucharest, May 2000. +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C Based on the RASP routines SFRLW, SFRLW1, SFRRW and SFRRW1, +C by A. Varga, 1992. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Frequency weighting, model reduction, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOB, WEIGHT + INTEGER INFO, IWARN, LDA, LDAV, LDAW, LDB, LDBV, LDBW, + $ LDC, LDCV, LDCW, LDD, LDDV, LDDW, LDWORK, M, N, + $ NV, NW, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ AV(LDAV,*), BV(LDBV,*), CV(LDCV,*), DV(LDDV,*), + $ AW(LDAW,*), BW(LDBW,*), CW(LDCW,*), DW(LDDW,*), + $ DWORK(*) +C .. Local Scalars + LOGICAL CONJS, DISCR, FRWGHT, LEFTW, RIGHTW + DOUBLE PRECISION SCALE, WORK + INTEGER I, IA, IB, IERR, KW, LDW, LDWN, LW +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DTRSYL, SB04PY, TB01WD, XERBLA +C .. Executable Statements .. +C + CONJS = LSAME( JOB, 'C' ) + DISCR = LSAME( DICO, 'D' ) + LEFTW = LSAME( WEIGHT, 'L' ) .OR. LSAME( WEIGHT, 'B' ) + RIGHTW = LSAME( WEIGHT, 'R' ) .OR. LSAME( WEIGHT, 'B' ) + FRWGHT = LEFTW .OR. RIGHTW +C + IWARN = 0 + INFO = 0 + IF ( DISCR .AND. CONJS ) THEN + IA = 2*NV + IB = 2*NW + ELSE + IA = 0 + IB = 0 + END IF + LW = 1 + IF( LEFTW ) + $ LW = MAX( LW, NV*( NV + 5 ), NV*N + MAX( IA, P*N, P*M ) ) + IF( RIGHTW ) + $ LW = MAX( LW, NW*( NW + 5 ), NW*N + MAX( IB, M*N, P*M ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( JOB, 'N' ) .OR. CONJS ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -2 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( NV.LT.0 ) THEN + INFO = -5 + ELSE IF( NW.LT.0 ) THEN + INFO = -6 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( P.LT.0 ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDAV.LT.1 .OR. ( LEFTW .AND. LDAV.LT.NV ) ) THEN + INFO = -18 + ELSE IF( LDBV.LT.1 .OR. ( LEFTW .AND. LDBV.LT.NV ) ) THEN + INFO = -20 + ELSE IF( LDCV.LT.1 .OR. ( LEFTW .AND. LDCV.LT.P ) ) THEN + INFO = -22 + ELSE IF( LDDV.LT.1 .OR. ( LEFTW .AND. LDDV.LT.P ) ) THEN + INFO = -24 + ELSE IF( LDAW.LT.1 .OR. ( RIGHTW .AND. LDAW.LT.NW ) ) THEN + INFO = -26 + ELSE IF( LDBW.LT.1 .OR. ( RIGHTW .AND. LDBW.LT.NW ) ) THEN + INFO = -28 + ELSE IF( LDCW.LT.1 .OR. ( RIGHTW .AND. LDCW.LT.M ) ) THEN + INFO = -30 + ELSE IF( LDDW.LT.1 .OR. ( RIGHTW .AND. LDDW.LT.M ) ) THEN + INFO = -32 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -34 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09KX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( .NOT.FRWGHT .OR. MIN( M, P ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + WORK = ONE + IF( LEFTW .AND. NV.GT.0 ) THEN +C +C Reduce AV to a real Schur form using an orthogonal similarity +C transformation AV <- Q'*AV*Q and apply the transformation to +C BV and CV: BV <- Q'*BV and CV <- CV*Q. +C +C Workspace needed: NV*(NV+5); +C prefer larger. +C + KW = NV*( NV + 2 ) + 1 + CALL TB01WD( NV, P, P, AV, LDAV, BV, LDBV, CV, LDCV, + $ DWORK(2*NV+1), NV, DWORK, DWORK(NV+1), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C + IF( CONJS ) THEN +C +C Check the stability of the eigenvalues of AV. +C + IF ( DISCR ) THEN + DO 10 I = 1, NV + IF( DLAPY2( DWORK(I), DWORK(NV+I) ).GE.ONE) THEN + IWARN = 1 + GO TO 50 + END IF + 10 CONTINUE + ELSE + DO 20 I = 1, NV + IF( DWORK(I).GE.ZERO ) THEN + IWARN = 1 + GO TO 50 + END IF + 20 CONTINUE + END IF + ELSE +C +C Check the anti-stability of the eigenvalues of AV. +C + IF ( DISCR ) THEN + DO 30 I = 1, NV + IF( DLAPY2( DWORK(I), DWORK(NV+I) ).LE.ONE) THEN + IWARN = 1 + GO TO 50 + END IF + 30 CONTINUE + ELSE + DO 40 I = 1, NV + IF( DWORK(I).LE.ZERO ) THEN + IWARN = 1 + GO TO 50 + END IF + 40 CONTINUE + END IF + END IF + 50 CONTINUE +C + END IF +C + IF( RIGHTW .AND. NW.GT.0 ) THEN +C +C Reduce AW to a real Schur form using an orthogonal similarity +C transformation AW <- T'*AW*T and apply the transformation to +C BW and CW: BW <- T'*BW and CW <- CW*T. +C +C Workspace needed: NW*(NW+5); +C prefer larger. +C + KW = NW*( NW + 2 ) + 1 + CALL TB01WD( NW, M, M, AW, LDAW, BW, LDBW, CW, LDCW, + $ DWORK(2*NW+1), NW, DWORK, DWORK(NW+1), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WORK = MAX( WORK, DWORK(KW) + DBLE( KW - 1 ) ) +C + IF( CONJS ) THEN +C +C Check the stability of the eigenvalues of AW. +C + IF ( DISCR ) THEN + DO 60 I = 1, NW + IF( DLAPY2( DWORK(I), DWORK(NW+I) ).GE.ONE) THEN + IWARN = IWARN + 2 + GO TO 100 + END IF + 60 CONTINUE + ELSE + DO 70 I = 1, NW + IF( DWORK(I).GE.ZERO ) THEN + IWARN = IWARN + 2 + GO TO 100 + END IF + 70 CONTINUE + END IF + ELSE +C +C Check the anti-stability of the eigenvalues of AW. +C + IF ( DISCR ) THEN + DO 80 I = 1, NW + IF( DLAPY2( DWORK(I), DWORK(NW+I) ).LE.ONE) THEN + IWARN = IWARN + 2 + GO TO 100 + END IF + 80 CONTINUE + ELSE + DO 90 I = 1, NW + IF( DWORK(I).LE.ZERO ) THEN + IWARN = IWARN + 2 + GO TO 100 + END IF + 90 CONTINUE + END IF + END IF + 100 CONTINUE + END IF +C + IF( LEFTW ) THEN + LDW = MAX( NV, 1 ) + KW = NV*N + 1 + IF( CONJS ) THEN +C +C Compute the projection of conj(V)*G. +C +C Total workspace needed: NV*N + MAX( a, P*N, P*M ), where +C a = 0, if DICO = 'C', +C a = 2*NV, if DICO = 'D'. +C +C Compute -CV'*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'T', 'N', NV, N, P, -ONE, CV, LDCV, C, LDC, + $ ZERO, DWORK, LDW ) +C + IF( DISCR ) THEN +C +C Compute X and SCALE satisfying +C +C AV'*X*A - X = -SCALE*CV'*C. +C +C Additional workspace needed: 2*NV. +C + CALL SB04PY( 'T', 'N', -1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, DWORK(KW), IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct C <- DV'*C + BV'*X*A/SCALE, +C D <- DV'*D + BV'*X*B/SCALE. +C +C Additional workspace needed: MAX( P*N, P*M ). +C +C C <- DV'*C. +C + CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) +C +C D <- DV'*D. +C + CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) +C +C C <- C + BV'*X*A/SCALE. +C + CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK, LDW, ZERO, DWORK(KW), P ) + CALL DGEMM( 'N', 'N', P, N, N, ONE, DWORK(KW), P, A, LDA, + $ ONE, C, LDC ) +C +C D <- D + BV'*X*B/SCALE. +C + CALL DGEMM( 'N', 'N', P, M, N, ONE, DWORK(KW), P, B, LDB, + $ ONE, D, LDD ) + ELSE +C +C Compute X and SCALE satisfying +C +C AV'*X + X*A + SCALE*CV'*C = 0. +C + CALL DTRSYL( 'T', 'N', 1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct C and D. +C Additional workspace needed: MAX( P*N, P*M ). +C +C Construct C <- BV'*X/SCALE + DV'*C. +C + CALL DGEMM( 'T', 'N', P, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) + CALL DGEMM( 'T', 'N', P, N, NV, ONE / SCALE, BV, LDBV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV'*D. +C + CALL DGEMM( 'T', 'N', P, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) + END IF + ELSE +C +C Compute the projection of V*G. +C +C Total workspace needed: NV*N + MAX( P*N, P*M ). +C +C Compute -BV*C. +C Workspace needed: NV*N. +C + CALL DGEMM( 'N', 'N', NV, N, P, -ONE, BV, LDBV, C, LDC, + $ ZERO, DWORK, LDW ) +C +C Compute X and SCALE satisfying +C +C AV*X - X*A + SCALE*BV*C = 0. +C + CALL DTRSYL( 'N', 'N', -1, NV, N, AV, LDAV, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Construct C <- CV*X/SCALE + DV*C. +C + CALL DGEMM( 'N', 'N', P, N, P, ONE, DV, LDDV, C, LDC, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, N, DWORK(KW), P, C, LDC ) + CALL DGEMM( 'N', 'N', P, N, NV, ONE / SCALE, CV, LDCV, + $ DWORK, LDW, ONE, C, LDC ) +C +C Construct D <- DV*D. +C + CALL DGEMM( 'N', 'N', P, M, P, ONE, DV, LDDV, D, LDD, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) + END IF + END IF +C + IF( RIGHTW ) THEN + LDWN = MAX( N, 1 ) + KW = N*NW + 1 + IF( CONJS ) THEN +C +C Compute the projection of G*conj(W) or of conj(V)*G*conj(W). +C +C Total workspace needed: NW*N + MAX( b, M*N, P*M ), where +C b = 0, if DICO = 'C', +C b = 2*NW, if DICO = 'D'. +C +C Compute -BW*B'. +C Workspace needed: N*NW. +C + LDW = MAX( NW, 1 ) + CALL DGEMM( 'N', 'T', NW, N, M, -ONE, BW, LDBW, B, LDB, + $ ZERO, DWORK, LDW ) +C + IF( DISCR ) THEN +C +C Compute Y' and SCALE satisfying +C +C AW*Y'*A' - Y' = -SCALE*BW*B'. +C +C Additional workspace needed: 2*NW. +C + CALL SB04PY( 'N', 'T', -1, NW, N, AW, LDAW, A, LDA, + $ DWORK, LDW, SCALE, DWORK(KW), IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C +C Construct B <- B*DW' + A*Y*CW'/SCALE, +C D <- D*DW' + C*Y*CW'/SCALE. +C +C Additional workspace needed: MAX( N*M, P*M ). +C +C B <- B*DW'. +C + CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) +C +C B <- B + A*Y*CW'/SCALE. +C + CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, + $ CW, LDCW, ZERO, DWORK(KW), LDWN ) + CALL DGEMM( 'N', 'N', N, M, N, ONE, A, LDA, + $ DWORK(KW), LDWN, ONE, B, LDB ) +C +C D <- D + C*Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'N', P, M, N, ONE, C, LDC, + $ DWORK(KW), LDWN, ONE, D, LDD ) + ELSE +C +C Compute Y' and SCALE satisfying +C +C AW*Y' + Y'*A' + SCALE*BW*B' = 0. +C + CALL DTRSYL( 'N', 'T', 1, NW, N, AW, LDAW, A, LDA, + $ DWORK, LDW, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C +C Construct B and D. +C Additional workspace needed: MAX( N*M, P*M ). +C +C Construct B <- B*DW' + Y*CW'/SCALE. +C + CALL DGEMM( 'N', 'T', N, M, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'T', 'T', N, M, NW, ONE / SCALE, DWORK, LDW, + $ CW, LDCW, ONE, B, LDB) +C +C D <- D*DW'. +C + CALL DGEMM( 'N', 'T', P, M, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) + END IF + ELSE +C +C Compute the projection of G*W or of V*G*W. +C +C Total workspace needed: NW*N + MAX( M*N, P*M ). +C +C Compute B*CW. +C Workspace needed: N*NW. +C + CALL DGEMM( 'N', 'N', N, NW, M, ONE, B, LDB, CW, LDCW, + $ ZERO, DWORK, LDWN ) +C +C Compute Y and SCALE satisfying +C +C A*Y - Y*AW - SCALE*B*CW = 0. +C + CALL DTRSYL( 'N', 'N', -1, N, NW, A, LDA, AW, LDAW, + $ DWORK, LDWN, SCALE, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C +C Construct B and D. +C Additional workspace needed: MAX( N*M, P*M ). +C Construct B <- B*DW + Y*BW/SCALE. +C + CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DW, LDDW, + $ ZERO, DWORK(KW), LDWN ) + CALL DLACPY( 'F', N, M, DWORK(KW), LDWN, B, LDB ) + CALL DGEMM( 'N', 'N', N, M, NW, ONE / SCALE, DWORK, LDWN, + $ BW, LDBW, ONE, B, LDB) +C +C D <- D*DW. +C + CALL DGEMM( 'N', 'N', P, M, M, ONE, D, LDD, DW, LDDW, + $ ZERO, DWORK(KW), P ) + CALL DLACPY( 'F', P, M, DWORK(KW), P, D, LDD ) + END IF + END IF +C + DWORK(1) = MAX( WORK, DBLE( LW ) ) +C + RETURN +C *** Last line of AB09KX *** + END diff --git a/mex/sources/libslicot/AB09MD.f b/mex/sources/libslicot/AB09MD.f new file mode 100644 index 000000000..aaa808bfe --- /dev/null +++ b/mex/sources/libslicot/AB09MD.f @@ -0,0 +1,474 @@ + SUBROUTINE AB09MD( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, + $ A, LDA, B, LDB, C, LDC, NS, HSV, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr) for an original +C state-space representation (A,B,C) by using either the square-root +C or the balancing-free square-root Balance & Truncate (B & T) +C model reduction method for the ALPHA-stable part of the system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root Balance & Truncate method; +C = 'N': use the balancing-free square-root +C Balance & Truncate method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order +C on entry, and NMIN is the order of a minimal realization +C of the ALPHA-stable part of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable +C part of the given system (computed in HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues in an +C upper real Schur form. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the ALPHA-stable part of the +C original system ordered decreasingly. +C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If ORDSEL = 'A', TOL contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL = c*HNORM(As,Bs,Cs), where c is a constant in the +C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the +C Hankel-norm of the ALPHA-stable part of the given system +C (computed in HSV(1)). +C If TOL <= 0 on entry, the used default value is +C TOL = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C This value is appropriate to compute a minimal realization +C of the ALPHA-stable part. +C If ORDSEL = 'F', the value of TOL is ignored. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if JOB = 'B'; +C LIWORK = N, if JOB = 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system. In this case, the resulting NR is set equal +C to NSMIN. +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system. In this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 3: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09MD determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) (2) +C +C such that +C +C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C) and (Ar,Br,Cr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The following procedure is used to reduce a given G: +C +C 1) Decompose additively G as +C +C G = G1 + G2 +C +C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. +C +C 2) Determine G1r, a reduced order approximation of the +C ALPHA-stable part G1. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root +C Balance & Truncate method of [1] is used, and for an ALPHA-stable +C continuous-time system (DICO = 'C'), the resulting reduced model +C is balanced. For ALPHA-stable systems, setting TOL < 0, the +C routine can be used to compute balanced minimal state-space +C realizations. +C +C If JOB = 'N', the balancing-free square-root version of the +C Balance & Truncate method [2] is used to reduce the ALPHA-stable +C part G1. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), +C Vol. 2, pp. 42-46. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routines SADSDC, SRBT and SRBFT. +C +C REVISIONS +C +C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. +C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Balancing, minimal realization, model reduction, multivariable +C system, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDWORK, M, N, NR, + $ NS, P + DOUBLE PRECISION ALPHA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD + INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, + $ NN, NRA, NU, NU1, WRKOPT + DOUBLE PRECISION ALPWRK, MAXRED +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09AX, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -21 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + NN = N*N + KU = 1 + KWR = KU + NN + KWI = KWR + N + KW = KWI + N + LWR = LDWORK - KW + 1 +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LWR, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 +C +C Allocate working storage. +C + KT = 1 + KTI = KT + NN + KW = KTI + NN +C +C Compute a B & T approximation of the stable part. +C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; +C prefer larger. +C + CALL AB09AX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, HSV, DWORK(KT), N, + $ DWORK(KTI), N, TOL, IWORK, DWORK(KW), LDWORK-KW+1, + $ IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + NR = NRA + NU +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C + RETURN +C *** Last line of AB09MD *** + END diff --git a/mex/sources/libslicot/AB09ND.f b/mex/sources/libslicot/AB09ND.f new file mode 100644 index 000000000..49ea0c0cd --- /dev/null +++ b/mex/sources/libslicot/AB09ND.f @@ -0,0 +1,497 @@ + SUBROUTINE AB09ND( DICO, JOB, EQUIL, ORDSEL, N, M, P, NR, ALPHA, + $ A, LDA, B, LDB, C, LDC, D, LDD, NS, HSV, TOL1, + $ TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order model (Ar,Br,Cr,Dr) for an original +C state-space representation (A,B,C,D) by using either the +C square-root or the balancing-free square-root Singular +C Perturbation Approximation (SPA) model reduction method for the +C ALPHA-stable part of the system. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOB CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root SPA method; +C = 'N': use the balancing-free square-root SPA method. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NR is fixed; +C = 'A': the resulting order NR is automatically determined +C on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NR (input/output) INTEGER +C On entry with ORDSEL = 'F', NR is the desired order of the +C resulting reduced order system. 0 <= NR <= N. +C On exit, if INFO = 0, NR is the order of the resulting +C reduced order model. For a system with NU ALPHA-unstable +C eigenvalues and NS ALPHA-stable eigenvalues (NU+NS = N), +C NR is set as follows: if ORDSEL = 'F', NR is equal to +C NU+MIN(MAX(0,NR-NU),NMIN), where NR is the desired order +C on entry, and NMIN is the order of a minimal realization +C of the ALPHA-stable part of the given system; NMIN is +C determined as the number of Hankel singular values greater +C than NS*EPS*HNORM(As,Bs,Cs), where EPS is the machine +C precision (see LAPACK Library Routine DLAMCH) and +C HNORM(As,Bs,Cs) is the Hankel norm of the ALPHA-stable +C part of the given system (computed in HSV(1)); +C if ORDSEL = 'A', NR is the sum of NU and the number of +C Hankel singular values greater than +C MAX(TOL1,NS*EPS*HNORM(As,Bs,Cs)). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading NR-by-NR part of this +C array contains the state dynamics matrix Ar of the reduced +C order system. +C The resulting A has a block-diagonal form with two blocks. +C For a system with NU ALPHA-unstable eigenvalues and +C NS ALPHA-stable eigenvalues (NU+NS = N), the leading +C NU-by-NU block contains the unreduced part of A +C corresponding to ALPHA-unstable eigenvalues in an +C upper real Schur form. +C The trailing (NR+NS-N)-by-(NR+NS-N) block contains +C the reduced part of A corresponding to ALPHA-stable +C eigenvalues. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading NR-by-M part of this +C array contains the input/state matrix Br of the reduced +C order system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-NR part of this +C array contains the state/output matrix Cr of the reduced +C order system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original input/output matrix D. +C On exit, if INFO = 0, the leading P-by-M part of this +C array contains the input/output matrix Dr of the reduced +C order system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the ALPHA-stable part of the +C original system ordered decreasingly. +C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of reduced system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(As,Bs,Cs), where c is a constant in the +C interval [0.00001,0.001], and HNORM(As,Bs,Cs) is the +C Hankel-norm of the ALPHA-stable part of the given system +C (computed in HSV(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NS*EPS*HNORM(As,Bs,Cs), where NS is the number of +C ALPHA-stable eigenvalues of A and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C This value is appropriate to compute a minimal realization +C of the ALPHA-stable part. +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given system. +C The recommended value is TOL2 = NS*EPS*HNORM(As,Bs,Cs). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0, then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,2*N) +C On exit, if INFO = 0, IWORK(1) contains the order of the +C minimal realization of the ALPHA-stable part of the +C system. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C system. In this case, the resulting NR is set equal +C to NSMIN. +C = 2: with ORDSEL = 'F', the selected order NR is less +C than the order of the ALPHA-unstable part of the +C given system. In this case NR is set equal to the +C order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 3: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system. The subroutine AB09ND determines for +C the given system (1), the matrices of a reduced order system +C +C d[z(t)] = Ar*z(t) + Br*u(t) +C yr(t) = Cr*z(t) + Dr*u(t) (2) +C +C such that +C +C HSV(NR+NS-N) <= INFNORM(G-Gr) <= 2*[HSV(NR+NS-N+1)+...+HSV(NS)], +C +C where G and Gr are transfer-function matrices of the systems +C (A,B,C,D) and (Ar,Br,Cr,Dr), respectively, and INFNORM(G) is the +C infinity-norm of G. +C +C The following procedure is used to reduce a given G: +C +C 1) Decompose additively G as +C +C G = G1 + G2 +C +C such that G1 = (As,Bs,Cs,D) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu,0) has only ALPHA-unstable poles. +C +C 2) Determine G1r, a reduced order approximation of the +C ALPHA-stable part G1. +C +C 3) Assemble the reduced model Gr as +C +C Gr = G1r + G2. +C +C To reduce the ALPHA-stable part G1, if JOB = 'B', the square-root +C balancing-based SPA method of [1] is used, and for an ALPHA-stable +C system, the resulting reduced model is balanced. +C +C If JOB = 'N', the balancing-free square-root SPA method of [2] +C is used to reduce the ALPHA-stable part G1. +C By setting TOL1 = TOL2, the routine can be used to compute +C Balance & Truncate approximations as well. +C +C REFERENCES +C +C [1] Liu Y. and Anderson B.D.O. +C Singular Perturbation Approximation of Balanced Systems, +C Int. J. Control, Vol. 50, pp. 1379-1405, 1989. +C +C [2] Varga A. +C Balancing-free square-root algorithm for computing +C singular perturbation approximations. +C Proc. 30-th IEEE CDC, Brighton, Dec. 11-13, 1991, +C Vol. 2, pp. 1062-1065. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routines SADSDC and SRBFSP. +C +C REVISIONS +C +C Mar. 1999, V. Sima, Research Institute for Informatics, Bucharest. +C Nov. 2000, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Balancing, minimal realization, model reduction, multivariable +C system, singular perturbation approximation, state-space model, +C state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOB, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, + $ M, N, NR, NS, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR, FIXORD + INTEGER IERR, IWARNL, KT, KTI, KU, KW, KWI, KWR, LWR, + $ NN, NRA, NU, NU1, WRKOPT + DOUBLE PRECISION ALPWRK, MAXRED +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09BX, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + FIXORD = LSAME( ORDSEL, 'F' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOB, 'B' ) .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( FIXORD .AND. ( NR.LT.0 .OR. NR.GT.N ) ) THEN + INFO = -8 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -21 + ELSE IF( LDWORK.LT.MAX( 1, N*( 2*N + MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -24 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB09ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NR = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + NN = N*N + KU = 1 + KWR = KU + NN + KWI = KWR + N + KW = KWI + N + LWR = LDWORK - KW + 1 +C +C Reduce A to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Unstable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NU, DWORK(KU), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LWR, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + IWARNL = 0 + NS = N - NU + IF( FIXORD ) THEN + NRA = MAX( 0, NR-NU ) + IF( NR.LT.NU ) + $ IWARNL = 2 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NS.EQ.0 ) THEN + NR = NU + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C + NU1 = NU + 1 +C +C Allocate working storage. +C + KT = 1 + KTI = KT + NN + KW = KTI + NN +C +C Compute a SPA of the stable part. +C Workspace: need N*(2*N+MAX(N,M,P)+5) + N*(N+1)/2; +C prefer larger. +C + CALL AB09BX( DICO, JOB, ORDSEL, NS, M, P, NRA, A(NU1,NU1), LDA, + $ B(NU1,1), LDB, C(1,NU1), LDC, D, LDD, HSV, + $ DWORK(KT), N, DWORK(KTI), N, TOL1, TOL2, IWORK, + $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 1 + RETURN + END IF +C + NR = NRA + NU +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C + RETURN +C *** Last line of AB09ND *** + END diff --git a/mex/sources/libslicot/AB13AD.f b/mex/sources/libslicot/AB13AD.f new file mode 100644 index 000000000..fb2b2018e --- /dev/null +++ b/mex/sources/libslicot/AB13AD.f @@ -0,0 +1,349 @@ + DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A, + $ LDA, B, LDB, C, LDC, NS, HSV, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Hankel-norm of the ALPHA-stable projection of the +C transfer-function matrix G of the state-space system (A,B,C). +C +C FUNCTION VALUE +C +C AB13AD DOUBLE PRECISION +C The Hankel-norm of the ALPHA-stable projection of G +C (if INFO = 0). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix A. For a continuous-time +C system (DICO = 'C'), ALPHA <= 0 is the boundary value for +C the real parts of eigenvalues, while for a discrete-time +C system (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary +C (see the Note below). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, if INFO = 0, the leading N-by-N part of this +C array contains the state dynamics matrix A in a block +C diagonal real Schur form with its eigenvalues reordered +C and separated. The resulting A has two diagonal blocks. +C The leading NS-by-NS part of A has eigenvalues in the +C ALPHA-stability domain and the trailing (N-NS) x (N-NS) +C part has eigenvalues outside the ALPHA-stability domain. +C Note: The ALPHA-stability domain is defined either +C as the open half complex plane left to ALPHA, +C for a continous-time system (DICO = 'C'), or the +C interior of the ALPHA-radius circle centered in the +C origin, for a discrete-time system (DICO = 'D'). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the input/state matrix B of the transformed +C system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, if INFO = 0, the leading P-by-N part of this +C array contains the state/output matrix C of the +C transformed system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NS (output) INTEGER +C The dimension of the ALPHA-stable subsystem. +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, the leading NS elements of HSV contain the +C Hankel singular values of the ALPHA-stable part of the +C original system ordered decreasingly. +C HSV(1) is the Hankel norm of the ALPHA-stable subsystem. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the computation of the ordered real Schur form of A +C failed; +C = 2: the separation of the ALPHA-stable/unstable diagonal +C blocks failed because of very close eigenvalues; +C = 3: the computed ALPHA-stable part is just stable, +C having stable eigenvalues very near to the imaginary +C axis (if DICO = 'C') or to the unit circle +C (if DICO = 'D'); +C = 4: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the following linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let G be the corresponding +C transfer-function matrix. The following procedure is used to +C compute the Hankel-norm of the ALPHA-stable projection of G: +C +C 1) Decompose additively G as +C +C G = G1 + G2 +C +C such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and +C G2 = (Au,Bu,Cu) has only ALPHA-unstable poles. +C For the computation of the additive decomposition, the +C algorithm presented in [1] is used. +C +C 2) Compute the Hankel-norm of ALPHA-stable projection G1 as the +C the maximum Hankel singular value of the system (As,Bs,Cs). +C The computation of the Hankel singular values is performed +C by using the square-root method of [2]. +C +C REFERENCES +C +C [1] Safonov, M.G., Jonckheere, E.A., Verma, M. and Limebeer, D.J. +C Synthesis of positive real multivariable feedback systems, +C Int. J. Control, Vol. 45, pp. 817-842, 1987. +C +C [2] Tombs, M.S. and Postlethwaite, I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented method relies on a square-root technique. +C 3 +C The algorithms require about 17N floating point operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SHANRM. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Additive spectral decomposition, model reduction, +C multivariable system, state-space model, system norms. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NS, P + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER IERR, KT, KW, KW1, KW2 + DOUBLE PRECISION ALPWRK, MAXRED, WRKOPT +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION AB13AX, DLAMCH + EXTERNAL AB13AX, DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -16 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB13AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NS = 0 + AB13AD = ZERO + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(D)*A*D, B <- inv(D)*B and C <- C*D, where D is a +C diagonal matrix. +C Workspace: N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Allocate working storage. +C + KT = 1 + KW1 = N*N + 1 + KW2 = KW1 + N + KW = KW2 + N +C +C Reduce A to a block diagonal real Schur form, with the +C ALPHA-stable part in the leading diagonal position, using a +C non-orthogonal similarity transformation A <- inv(T)*A*T and +C apply the transformation to B and C: B <- inv(T)*B and C <- C*T. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01KD( DICO, 'Stable', 'General', N, M, P, ALPWRK, A, LDA, + $ B, LDB, C, LDC, NS, DWORK(KT), N, DWORK(KW1), + $ DWORK(KW2), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 1 + ELSE + INFO = 2 + END IF + RETURN + END IF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C + IF( NS.EQ.0 ) THEN + AB13AD = ZERO + ELSE +C +C Workspace: need N*(MAX(N,M,P)+5)+N*(N+1)/2; +C prefer larger. +C + AB13AD = AB13AX( DICO, NS, M, P, A, LDA, B, LDB, C, LDC, HSV, + $ DWORK, LDWORK, IERR ) +C + IF( IERR.NE.0 ) THEN + INFO = IERR + 2 + RETURN + END IF +C + DWORK(1) = MAX( WRKOPT, DWORK(1) ) + END IF +C + RETURN +C *** Last line of AB13AD *** + END diff --git a/mex/sources/libslicot/AB13AX.f b/mex/sources/libslicot/AB13AX.f new file mode 100644 index 000000000..4053e2a7e --- /dev/null +++ b/mex/sources/libslicot/AB13AX.f @@ -0,0 +1,308 @@ + DOUBLE PRECISION FUNCTION AB13AX( DICO, N, M, P, A, LDA, B, LDB, + $ C, LDC, HSV, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Hankel-norm of the transfer-function matrix G of +C a stable state-space system (A,B,C). The state dynamics matrix A +C of the given system is an upper quasi-triangular matrix in +C real Schur form. +C +C FUNCTION VALUE +C +C AB13AX DOUBLE PRECISION +C The Hankel-norm of G (if INFO = 0). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A in a real Schur canonical form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, this array contains the Hankel singular +C values of the given system ordered decreasingly. +C HSV(1) is the Hankel norm of the given system. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the state matrix A is not stable (if DICO = 'C') +C or not convergent (if DICO = 'D'); +C = 2: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the stable linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let G be the corresponding +C transfer-function matrix. The Hankel-norm of G is computed as the +C the maximum Hankel singular value of the system (A,B,C). +C The computation of the Hankel singular values is performed +C by using the square-root method of [1]. +C +C REFERENCES +C +C [1] Tombs M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C NUMERICAL ASPECTS +C +C The implemented method relies on a square-root technique. +C 3 +C The algorithms require about 17N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SHANRM. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Feb. 2000, V. Sima, Research Institute for Informatics, Bucharest. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Multivariable system, state-space model, system norms. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER I, IERR, J, KR, KS, KTAU, KU, KW, MNMP + DOUBLE PRECISION SCALEC, SCALEO, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DSCAL, DTPMV, MA02DD, MB03UD, SB03OU, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) + + $ ( N*( N + 1 ) )/2 ) ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB13AX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + AB13AX = ZERO + DWORK(1) = ONE + RETURN + END IF +C +C Allocate N*MAX(N,M,P), N, and N*(N+1)/2 working storage for the +C matrices S, TAU, and R, respectively. S shares the storage with U. +C + KU = 1 + KS = 1 + MNMP = MAX( N, M, P ) + KTAU = KS + N*MNMP + KR = KTAU + N + KW = KR +C +C Copy C in U. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), MNMP ) +C +C If DISCR = .FALSE., solve for R the Lyapunov equation +C 2 +C A'*(R'*R) + (R'*R)*A + scaleo * C'*C = 0 . +C +C If DISCR = .TRUE., solve for R the Lyapunov equation +C 2 +C A'*(R'*R)*A + scaleo * C'*C = R'*R . +C +C Workspace needed: N*(MAX(N,M,P)+1); +C Additional workspace: need 4*N; +C prefer larger. +C + CALL SB03OU( DISCR, .FALSE., N, P, A, LDA, DWORK(KU), MNMP, + $ DWORK(KTAU), DWORK(KU), N, SCALEO, DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + ENDIF +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Pack the upper triangle of R in DWORK(KR). +C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2. +C + CALL MA02DD( 'Pack', 'Upper', N, DWORK(KU), N, DWORK(KR) ) +C + KW = KR + ( N*( N + 1 ) )/2 +C +C Copy B in S (over U). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KS), N ) +C +C If DISCR = .FALSE., solve for S the Lyapunov equation +C 2 +C A*(S*S') + (S*S')*A' + scalec *B*B' = 0 . +C +C If DISCR = .TRUE., solve for S the Lyapunov equation +C 2 +C A*(S*S')*A' + scalec *B*B' = S*S' . +C +C Workspace needed: N*(MAX(N,M,P) + 1) + N*(N+1)/2; +C Additional workspace: need 4*N; +C prefer larger. +C + CALL SB03OU( DISCR, .TRUE., N, M, A, LDA, DWORK(KS), N, + $ DWORK(KTAU), DWORK(KS), N, SCALEC, DWORK(KW), + $ LDWORK-KW+1, IERR ) +C + WRKOPT = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C +C | x x | +C Compute R*S in the form | 0 x | in S. Note that R is packed. +C + J = KS + DO 10 I = 1, N + CALL DTPMV( 'Upper', 'NoTranspose', 'NonUnit', I, DWORK(KR), + $ DWORK(J), 1 ) + J = J + N + 10 CONTINUE +C +C Compute the singular values of the upper triangular matrix R*S. +C +C Workspace needed: N*MAX(N,M,P); +C Additional workspace: need MAX(1,5*N); +C prefer larger. +C + KW = KTAU + CALL MB03UD( 'NoVectors', 'NoVectors', N, DWORK(KS), N, DWORK, 1, + $ HSV, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + ENDIF +C +C Scale singular values. +C + CALL DSCAL( N, ONE / SCALEC / SCALEO, HSV, 1 ) + AB13AX = HSV(1) +C + DWORK(1) = MAX( WRKOPT, DWORK(KW) + DBLE( KW-1 ) ) +C + RETURN +C *** Last line of AB13AX *** + END diff --git a/mex/sources/libslicot/AB13BD.f b/mex/sources/libslicot/AB13BD.f new file mode 100644 index 000000000..ac69fd7b6 --- /dev/null +++ b/mex/sources/libslicot/AB13BD.f @@ -0,0 +1,390 @@ + DOUBLE PRECISION FUNCTION AB13BD( DICO, JOBN, N, M, P, A, LDA, + $ B, LDB, C, LDC, D, LDD, NQ, TOL, + $ DWORK, LDWORK, IWARN, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the H2 or L2 norm of the transfer-function matrix G +C of the system (A,B,C,D). G must not have poles on the imaginary +C axis, for a continuous-time system, or on the unit circle, for +C a discrete-time system. If the H2-norm is computed, the system +C must be stable. +C +C FUNCTION VALUE +C +C AB13BD DOUBLE PRECISION +C The H2-norm of G, if JOBN = 'H', or the L2-norm of G, +C if JOBN = 'L' (if INFO = 0). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBN CHARACTER*1 +C Specifies the norm to be computed as follows: +C = 'H': the H2-norm; +C = 'L': the L2-norm. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of the +C matrix B, and the number of columns of the matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B and D. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices C and D. +C P represents the dimension of output vector. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix of the system. +C On exit, the leading NQ-by-NQ part of this array contains +C the state dynamics matrix (in a real Schur form) of the +C numerator factor Q of the right coprime factorization with +C inner denominator of G (see METHOD). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix of the system. +C On exit, the leading NQ-by-M part of this array contains +C the input/state matrix of the numerator factor Q of the +C right coprime factorization with inner denominator of G +C (see METHOD). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix of the system. +C On exit, the leading P-by-NQ part of this array contains +C the state/output matrix of the numerator factor Q of the +C right coprime factorization with inner denominator of G +C (see METHOD). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix of the system. +C If DICO = 'C', D must be a null matrix. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix of the numerator factor Q of +C the right coprime factorization with inner denominator +C of G (see METHOD). +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the resulting numerator Q of the right +C coprime factorization with inner denominator of G (see +C METHOD). +C Generally, NQ = N - NS, where NS is the number of +C uncontrollable unstable eigenvalues. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(B), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(B) denotes +C the 1-norm of B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, M*(N+M) + MAX( N*(N+5), M*(M+2), 4*P ), +C N*( MAX( N, P ) + 4 ) + MIN( N, P ) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C occured during the assignment of eigenvalues in +C computing the right coprime factorization with inner +C denominator of G (see the SLICOT subroutine SB08DD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the reordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal (see SLICOT routine SB08DD); +C = 3: if DICO = 'C' and the matrix A has a controllable +C eigenvalue on the imaginary axis, or DICO = 'D' +C and A has a controllable eigenvalue on the unit +C circle; +C = 4: the solution of Lyapunov equation failed because +C the equation is singular; +C = 5: if DICO = 'C' and D is a nonzero matrix; +C = 6: if JOBN = 'H' and the system is unstable. +C +C METHOD +C +C The subroutine is based on the algorithms proposed in [1] and [2]. +C +C If the given transfer-function matrix G is unstable, then a right +C coprime factorization with inner denominator of G is first +C computed +C -1 +C G = Q*R , +C +C where Q and R are stable transfer-function matrices and R is +C inner. If G is stable, then Q = G and R = I. +C Let (AQ,BQ,CQ,DQ) be the state-space representation of Q. +C +C If DICO = 'C', then the L2-norm of G is computed as +C +C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ)), +C +C where X satisfies the continuous-time Lyapunov equation +C +C AQ'*X + X*AQ + CQ'*CQ = 0. +C +C If DICO = 'D', then the l2-norm of G is computed as +C +C NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ+DQ'*DQ)), +C +C where X satisfies the discrete-time Lyapunov equation +C +C AQ'*X*AQ - X + CQ'*CQ = 0. +C +C REFERENCES +C +C [1] Varga A. +C On computing 2-norms of transfer-function matrices. +C Proc. 1992 ACC, Chicago, June 1992. +C +C [2] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SL2NRM. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C Jan. 2003, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Coprime factorization, Lyapunov equation, multivariable system, +C state-space model, system norms. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBN + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M, + $ N, NQ, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER KCR, KDR, KRW, KTAU, KU, MXNP, NR + DOUBLE PRECISION S2NORM, SCALE, WRKOPT +C .. External functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLAPY2 + EXTERNAL DLANGE, DLAPY2, LSAME +C .. External subroutines .. + EXTERNAL DLACPY, DTRMM, SB03OU, SB08DD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + INFO = 0 + IWARN = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( JOBN, 'H' ) .OR. LSAME( JOBN, 'L' ) ) ) + $ THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDWORK.LT.MAX( 1, M*( N + M ) + + $ MAX( N*( N + 5 ), M*( M + 2 ), 4*P ), + $ N*( MAX( N, P ) + 4 ) + MIN( N, P ) ) ) + $ THEN + INFO = -17 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'AB13BD', -INFO ) + RETURN + END IF +C +C Compute the Frobenius norm of D. +C + S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) + IF( .NOT.DISCR .AND. S2NORM.NE.ZERO ) THEN + INFO = 5 + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + NQ = 0 + AB13BD = ZERO + DWORK(1) = ONE + RETURN + END IF +C + KCR = 1 + KDR = KCR + M*N + KRW = KDR + M*M +C +C Compute the right coprime factorization with inner denominator +C of G. +C +C Workspace needed: M*(N+M); +C Additional workspace: need MAX( N*(N+5), M*(M+2), 4*M, 4*P ); +C prefer larger. +C + CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, NQ, + $ NR, DWORK(KCR), M, DWORK(KDR), M, TOL, DWORK(KRW), + $ LDWORK-KRW+1, IWARN, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = DWORK(KRW) + DBLE( KRW-1 ) +C +C Check stability. +C + IF( LSAME( JOBN, 'H' ) .AND. NR.GT.0 ) THEN + INFO = 6 + RETURN + END IF +C + IF( NQ.GT.0 ) THEN + KU = 1 + MXNP = MAX( NQ, P ) + KTAU = NQ*MXNP + 1 + KRW = KTAU + MIN( NQ, P ) +C +C Find X, the solution of Lyapunov equation. +C +C Workspace needed: N*MAX(N,P) + MIN(N,P); +C Additional workspace: 4*N; +C prefer larger. +C + CALL DLACPY( 'Full', P, NQ, C, LDC, DWORK(KU), MXNP ) + CALL SB03OU( DISCR, .FALSE., NQ, P, A, LDA, DWORK(KU), MXNP, + $ DWORK(KTAU), DWORK(KU), NQ, SCALE, DWORK(KRW), + $ LDWORK-KRW+1, INFO ) + IF( INFO.NE.0 ) THEN + IF( INFO.EQ.1 ) THEN + INFO = 4 + ELSE IF( INFO.EQ.2 ) THEN + INFO = 3 + END IF + RETURN + END IF +C + WRKOPT = MAX( WRKOPT, DWORK(KRW) + DBLE( KRW-1 ) ) +C +C Add the contribution of BQ'*X*BQ. +C +C Workspace needed: N*(N+M). +C + KTAU = NQ*NQ + 1 + CALL DLACPY( 'Full', NQ, M, B, LDB, DWORK(KTAU), NQ ) + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', NQ, M, + $ ONE, DWORK(KU), NQ, DWORK(KTAU), NQ ) + IF( NR.GT.0 ) + $ S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK ) + S2NORM = DLAPY2( S2NORM, DLANGE( 'Frobenius', NQ, M, + $ DWORK(KTAU), NQ, DWORK ) + $ / SCALE ) + END IF +C + AB13BD = S2NORM +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of AB13BD *** + END diff --git a/mex/sources/libslicot/AB13CD.f b/mex/sources/libslicot/AB13CD.f new file mode 100644 index 000000000..ec9fa2559 --- /dev/null +++ b/mex/sources/libslicot/AB13CD.f @@ -0,0 +1,601 @@ + DOUBLE PRECISION FUNCTION AB13CD( N, M, NP, A, LDA, B, LDB, C, + $ LDC, D, LDD, TOL, IWORK, DWORK, + $ LDWORK, CWORK, LCWORK, BWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the H-infinity norm of the continuous-time stable +C system +C +C | A | B | +C G(s) = |---|---| . +C | C | D | +C +C FUNCTION VALUE +C +C AB13CD DOUBLE PRECISION +C If INFO = 0, the H-infinity norm of the system, HNORM, +C i.e., the peak gain of the frequency response (as measured +C by the largest singular value in the MIMO case). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used to set the accuracy in determining the +C norm. +C +C Workspace +C +C IWORK INTEGER array, dimension N +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK, and DWORK(2) contains the frequency where the +C gain of the frequency response achieves its peak value +C HNORM. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(2,4*N*N+2*M*M+3*M*N+M*NP+2*(N+NP)*NP+10*N+ +C 6*max(M,NP)). +C For good performance, LDWORK must generally be larger. +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) contains the optimal value +C of LCWORK. +C +C LCWORK INTEGER +C The dimension of the array CWORK. +C LCWORK >= max(1,(N+M)*(N+NP)+3*max(M,NP)). +C For good performance, LCWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the system is unstable; +C = 2: the tolerance is too small (the algorithm for +C computing the H-infinity norm did not converge); +C = 3: errors in computing the eigenvalues of A or of the +C Hamiltonian matrix (the QR algorithm did not +C converge); +C = 4: errors in computing singular values. +C +C METHOD +C +C The routine implements the method presented in [1]. +C +C REFERENCES +C +C [1] Bruinsma, N.A. and Steinbuch, M. +C A fast algorithm to compute the Hinfinity-norm of a transfer +C function matrix. +C Systems & Control Letters, vol. 14, pp. 287-293, 1990. +C +C NUMERICAL ASPECTS +C +C If the algorithm does not converge (INFO = 2), the tolerance must +C be increased. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999, +C Oct. 2000. +C P.Hr. Petkov, October 2000. +C A. Varga, October 2000. +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, system norm. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 10 ) + COMPLEX*16 CONE, JIMAG + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), + $ JIMAG = ( 0.0D0, 1.0D0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + DOUBLE PRECISION HUGE + PARAMETER ( HUGE = 10.0D+0**30 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LCWORK, LDD, LDWORK, M, N, + $ NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + COMPLEX*16 CWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER I, ICW2, ICW3, ICW4, ICWRK, INFO2, ITER, IW10, + $ IW11, IW12, IW2, IW3, IW4, IW5, IW6, IW7, IW8, + $ IW9, IWRK, J, K, L, LCWAMX, LWAMAX, MINCWR, + $ MINWRK, SDIM + DOUBLE PRECISION DEN, FPEAK, GAMMA, GAMMAL, GAMMAU, OMEGA, RAT, + $ RATMAX, TEMP, WIMAX, WRMIN + LOGICAL COMPLX +C +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + LOGICAL SB02MV, SB02CX + EXTERNAL DLAPY2, SB02MV, SB02CX +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DGESV, DGESVD, DLACPY, DPOSV, + $ DPOTRF, DPOTRS, DSYRK, MA02ED, MB01RX, XERBLA, + $ ZGEMM, ZGESV, ZGESVD +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + END IF +C +C Compute workspace. +C + MINWRK = MAX( 2, 4*N*N + 2*M*M + 3*M*N + M*NP + 2*( N + NP )*NP + + $ 10*N + 6*MAX( M, NP ) ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -15 + END IF + MINCWR = MAX( 1, ( N + M )*( N + NP ) + 3*MAX( M, NP ) ) + IF( LCWORK.LT.MINCWR ) THEN + INFO = -17 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. NP.EQ.0 ) RETURN +C +C Workspace usage. +C + IW2 = N + IW3 = IW2 + N + IW4 = IW3 + N*N + IW5 = IW4 + N*M + IW6 = IW5 + NP*M + IWRK = IW6 + MIN( NP, M ) +C +C Determine the maximum singular value of G(infinity) = D . +C + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) + CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), + $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + GAMMAL = DWORK( IW6+1 ) + FPEAK = HUGE + LWAMAX = INT( DWORK( IWRK+1 ) ) + IWRK +C +C Quick return if N = 0 . +C + IF( N.EQ.0 ) THEN + AB13CD = GAMMAL + DWORK(1) = TWO + DWORK(2) = ZERO + CWORK(1) = ONE + RETURN + END IF +C +C Stability check. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) + CALL DGEES( 'N', 'S', SB02MV, N, DWORK( IW3+1 ), N, SDIM, DWORK, + $ DWORK( IW2+1 ), DWORK, N, DWORK( IWRK+1 ), + $ LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF + IF( SDIM.LT.N ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) +C +C Determine the maximum singular value of G(0) = -C*inv(A)*B + D . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW3+1 ), N ) + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IW4+1 ), N ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IW5+1 ), NP ) + CALL DGESV( N, M, DWORK( IW3+1 ), N, IWORK, DWORK( IW4+1 ), N, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGEMM( 'N', 'N', NP, M, N, -ONE, C, LDC, DWORK( IW4+1 ), N, + $ ONE, DWORK( IW5+1 ), NP ) + CALL DGESVD( 'N', 'N', NP, M, DWORK( IW5+1 ), NP, DWORK( IW6+1 ), + $ DWORK, NP, DWORK, M, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN + GAMMAL = DWORK( IW6+1 ) + FPEAK = ZERO + END IF + LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) +C +C Find a frequency which is close to the peak frequency. +C + COMPLX = .FALSE. + DO 10 I = 1, N + IF( DWORK( IW2+I ).NE.ZERO ) COMPLX = .TRUE. + 10 CONTINUE + IF( .NOT.COMPLX ) THEN + WRMIN = ABS( DWORK( 1 ) ) + DO 20 I = 2, N + IF( WRMIN.GT.ABS( DWORK( I ) ) ) WRMIN = ABS( DWORK( I ) ) + 20 CONTINUE + OMEGA = WRMIN + ELSE + RATMAX = ZERO + DO 30 I = 1, N + DEN = DLAPY2( DWORK( I ), DWORK( IW2+I ) ) + RAT = ABS( ( DWORK( IW2+I )/DWORK( I ) )/DEN ) + IF( RATMAX.LT.RAT ) THEN + RATMAX = RAT + WIMAX = DEN + END IF + 30 CONTINUE + OMEGA = WIMAX + END IF +C +C Workspace usage. +C + ICW2 = N*N + ICW3 = ICW2 + N*M + ICW4 = ICW3 + NP*N + ICWRK = ICW4 + NP*M +C +C Determine the maximum singular value of +C G(omega) = C*inv(j*omega*In - A)*B + D . +C + DO 50 J = 1, N + DO 40 I = 1, N + CWORK( I+(J-1)*N ) = -A( I, J ) + 40 CONTINUE + CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) + 50 CONTINUE + DO 70 J = 1, M + DO 60 I = 1, N + CWORK( ICW2+I+(J-1)*N ) = B( I, J ) + 60 CONTINUE + 70 CONTINUE + DO 90 J = 1, N + DO 80 I = 1, NP + CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) + 80 CONTINUE + 90 CONTINUE + DO 110 J = 1, M + DO 100 I = 1, NP + CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) + 100 CONTINUE + 110 CONTINUE + CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, + $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) + CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, DWORK( IW6+1 ), + $ CWORK, NP, CWORK, M, CWORK( ICWRK+1 ), LCWORK-ICWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN + GAMMAL = DWORK( IW6+1 ) + FPEAK = OMEGA + END IF + LCWAMX = INT( CWORK( ICWRK+1 ) ) + ICWRK +C +C Workspace usage. +C + IW2 = M*N + IW3 = IW2 + M*M + IW4 = IW3 + NP*NP + IW5 = IW4 + M*M + IW6 = IW5 + M*N + IW7 = IW6 + M*N + IW8 = IW7 + NP*NP + IW9 = IW8 + NP*N + IW10 = IW9 + 4*N*N + IW11 = IW10 + 2*N + IW12 = IW11 + 2*N + IWRK = IW12 + MIN( NP, M ) +C +C Compute D'*C . +C + CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, + $ DWORK, M ) +C +C Compute D'*D . +C + CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ZERO, DWORK( IW2+1 ), + $ M ) +C +C Compute D*D' . +C + CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ZERO, DWORK( IW3+1 ), + $ NP ) +C +C Main iteration loop for gamma. +C + ITER = 0 + 120 ITER = ITER + 1 + IF( ITER.GT.MAXIT ) THEN + INFO = 2 + RETURN + END IF + GAMMA = ( ONE + TWO*TOL )*GAMMAL +C +C Compute R = GAMMA^2*Im - D'*D . +C + DO 140 J = 1, M + DO 130 I = 1, J + DWORK( IW4+I+(J-1)*M ) = -DWORK( IW2+I+(J-1)*M ) + 130 CONTINUE + DWORK( IW4+J+(J-1)*M ) = GAMMA**2 - DWORK( IW2+J+(J-1)*M ) + 140 CONTINUE +C +C Compute inv(R)*D'*C . +C + CALL DLACPY( 'Full', M, N, DWORK, M, DWORK( IW5+1 ), M ) + CALL DPOTRF( 'U', M, DWORK( IW4+1 ), M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW5+1 ), M, + $ INFO2 ) +C +C Compute inv(R)*B' . +C + DO 160 J = 1, N + DO 150 I = 1, M + DWORK( IW6+I+(J-1)*M ) = B( J, I ) + 150 CONTINUE + 160 CONTINUE + CALL DPOTRS( 'U', M, N, DWORK( IW4+1 ), M, DWORK( IW6+1 ), M, + $ INFO2 ) +C +C Compute S = GAMMA^2*Ip - D*D' . +C + DO 180 J = 1, NP + DO 170 I = 1, J + DWORK( IW7+I+(J-1)*NP ) = -DWORK( IW3+I+(J-1)*NP ) + 170 CONTINUE + DWORK( IW7+J+(J-1)*NP ) = GAMMA**2 - DWORK( IW3+J+(J-1)*NP ) + 180 CONTINUE +C +C Compute inv(S)*C . +C + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IW8+1 ), NP ) + CALL DPOSV( 'U', NP, N, DWORK( IW7+1 ), NP, DWORK( IW8+1 ), NP, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Construct the Hamiltonian matrix . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IW9+1 ), 2*N ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( IW5+1 ), M, + $ ONE, DWORK( IW9+1 ), 2*N ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', N, NP, ZERO, -GAMMA, + $ DWORK( IW9+N+1 ), 2*N, C, LDC, DWORK( IW8+1 ), NP, + $ INFO2 ) + CALL MA02ED( 'Upper', N, DWORK( IW9+N+1 ), 2*N ) + CALL MB01RX( 'Left', 'Upper', 'NoTranspose', N, M, ZERO, GAMMA, + $ DWORK( IW9+2*N*N+1 ), 2*N, B, LDB, DWORK( IW6+1 ), M, + $ INFO2 ) + CALL MA02ED( 'Upper', N, DWORK( IW9+2*N*N+1 ), 2*N ) + DO 200 J = 1, N + DO 190 I = 1, N + DWORK( IW9+2*N*N+N+I+(J-1)*2*N ) = -DWORK( IW9+J+(I-1)*2*N ) + 190 CONTINUE + 200 CONTINUE +C +C Compute the eigenvalues of the Hamiltonian matrix. +C + CALL DGEES( 'N', 'S', SB02CX, 2*N, DWORK( IW9+1 ), 2*N, SDIM, + $ DWORK( IW10+1 ), DWORK( IW11+1 ), DWORK, 2*N, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK+1 ) ) + IWRK, LWAMAX ) +C + IF( SDIM.EQ.0 ) THEN + GAMMAU = GAMMA + GO TO 330 + END IF +C +C Store the positive imaginary parts. +C + J = 0 + DO 210 I = 1, SDIM-1, 2 + J = J + 1 + DWORK( IW10+J ) = DWORK( IW11+I ) + 210 CONTINUE + K = J +C + IF( K.GE.2 ) THEN +C +C Reorder the imaginary parts. +C + DO 230 J = 1, K-1 + DO 220 L = J+1, K + IF( DWORK( IW10+J ).LE. DWORK( IW10+L ) ) GO TO 220 + TEMP = DWORK( IW10+J ) + DWORK( IW10+J ) = DWORK( IW10+L ) + DWORK( IW10+L ) = TEMP + 220 CONTINUE + 230 CONTINUE +C +C Determine the next frequency. +C + DO 320 L = 1, K - 1 + OMEGA = ( DWORK( IW10+L ) + DWORK( IW10+L+1 ) )/TWO + DO 250 J = 1, N + DO 240 I = 1, N + CWORK( I+(J-1)*N ) = -A( I, J ) + 240 CONTINUE + CWORK( J+(J-1)*N ) = JIMAG*OMEGA - A( J, J ) + 250 CONTINUE + DO 270 J = 1, M + DO 260 I = 1, N + CWORK( ICW2+I+(J-1)*N ) = B( I, J ) + 260 CONTINUE + 270 CONTINUE + DO 290 J = 1, N + DO 280 I = 1, NP + CWORK( ICW3+I+(J-1)*NP ) = C( I, J ) + 280 CONTINUE + 290 CONTINUE + DO 310 J = 1, M + DO 300 I = 1, NP + CWORK( ICW4+I+(J-1)*NP ) = D( I, J ) + 300 CONTINUE + 310 CONTINUE + CALL ZGESV( N, M, CWORK, N, IWORK, CWORK( ICW2+1 ), N, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL ZGEMM( 'N', 'N', NP, M, N, CONE, CWORK( ICW3+1 ), NP, + $ CWORK( ICW2+1 ), N, CONE, CWORK( ICW4+1 ), NP ) + CALL ZGESVD( 'N', 'N', NP, M, CWORK( ICW4+1 ), NP, + $ DWORK( IW6+1 ), CWORK, NP, CWORK, M, + $ CWORK( ICWRK+1 ), LCWORK-ICWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + IF( GAMMAL.LT.DWORK( IW6+1 ) ) THEN + GAMMAL = DWORK( IW6+1 ) + FPEAK = OMEGA + END IF + LCWAMX = MAX( INT( CWORK( ICWRK+1 ) ) + ICWRK, LCWAMX ) + 320 CONTINUE + END IF + GO TO 120 + 330 AB13CD = ( GAMMAL + GAMMAU )/TWO +C + DWORK( 1 ) = LWAMAX + DWORK( 2 ) = FPEAK + CWORK( 1 ) = LCWAMX + RETURN +C *** End of AB13CD *** + END diff --git a/mex/sources/libslicot/AB13DD.f b/mex/sources/libslicot/AB13DD.f new file mode 100644 index 000000000..e9df19f47 --- /dev/null +++ b/mex/sources/libslicot/AB13DD.f @@ -0,0 +1,1870 @@ + SUBROUTINE AB13DD( DICO, JOBE, EQUIL, JOBD, N, M, P, FPEAK, + $ A, LDA, E, LDE, B, LDB, C, LDC, D, LDD, GPEAK, + $ TOL, IWORK, DWORK, LDWORK, CWORK, LCWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the L-infinity norm of a continuous-time or +C discrete-time system, either standard or in the descriptor form, +C +C -1 +C G(lambda) = C*( lambda*E - A ) *B + D . +C +C The norm is finite if and only if the matrix pair (A,E) has no +C eigenvalue on the boundary of the stability domain, i.e., the +C imaginary axis, or the unit circle, respectively. It is assumed +C that the matrix E is nonsingular. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system, as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBE CHARACTER*1 +C Specifies whether E is a general square or an identity +C matrix, as follows: +C = 'G': E is a general square matrix; +C = 'I': E is the identity matrix. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the system (A,E,B,C) or (A,B,C), as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C P (input) INTEGER +C The row size of the matrix C. P >= 0. +C +C FPEAK (input/output) DOUBLE PRECISION array, dimension (2) +C On entry, this parameter must contain an estimate of the +C frequency where the gain of the frequency response would +C achieve its peak value. Setting FPEAK(2) = 0 indicates an +C infinite frequency. An accurate estimate could reduce the +C number of iterations of the iterative algorithm. If no +C estimate is available, set FPEAK(1) = 0, and FPEAK(2) = 1. +C FPEAK(1) >= 0, FPEAK(2) >= 0. +C On exit, if INFO = 0, this array contains the frequency +C OMEGA, where the gain of the frequency response achieves +C its peak value GPEAK, i.e., +C +C || G ( j*OMEGA ) || = GPEAK , if DICO = 'C', or +C +C j*OMEGA +C || G ( e ) || = GPEAK , if DICO = 'D', +C +C where OMEGA = FPEAK(1), if FPEAK(2) > 0, and OMEGA is +C infinite, if FPEAK(2) = 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C If JOBE = 'G', the leading N-by-N part of this array must +C contain the descriptor matrix E of the system. +C If JOBE = 'I', then E is assumed to be the identity +C matrix and is not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. +C LDE >= MAX(1,N), if JOBE = 'G'; +C LDE >= 1, if JOBE = 'I'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this array must +C contain the direct transmission matrix D. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C GPEAK (output) DOUBLE PRECISION array, dimension (2) +C The L-infinity norm of the system, i.e., the peak gain +C of the frequency response (as measured by the largest +C singular value in the MIMO case), coded in the same way +C as FPEAK. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used to set the accuracy in determining the +C norm. 0 <= TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= K, where K can be computed using the following +C pseudo-code (or the Fortran code included in the routine) +C +C d = 6*MIN(P,M); +C c = MAX( 4*MIN(P,M) + MAX(P,M), d ); +C if ( MIN(P,M) = 0 ) then +C K = 1; +C else if( N = 0 or B = 0 or C = 0 ) then +C if( JOBD = 'D' ) then +C K = P*M + c; +C else +C K = 1; +C end +C else +C if ( DICO = 'D' ) then +C b = 0; e = d; +C else +C b = N*(N+M); e = c; +C if ( JOBD = Z' ) then b = b + P*M; end +C end +C if ( JOBD = 'D' ) then +C r = P*M; +C if ( JOBE = 'I', DICO = 'C', +C N > 0, B <> 0, C <> 0 ) then +C K = P*P + M*M; +C r = r + N*(P+M); +C else +C K = 0; +C end +C K = K + r + c; r = r + MIN(P,M); +C else +C r = 0; K = 0; +C end +C r = r + N*(N+P+M); +C if ( JOBE = 'G' ) then +C r = r + N*N; +C if ( EQUIL = 'S' ) then +C K = MAX( K, r + 9*N ); +C end +C K = MAX( K, r + 4*N + MAX( M, 2*N*N, N+b+e ) ); +C else +C K = MAX( K, r + N + +C MAX( M, P, N*N+2*N, 3*N+b+e ) ); +C end +C w = 0; +C if ( JOBE = 'I', DICO = 'C' ) then +C w = r + 4*N*N + 11*N; +C if ( JOBD = 'D' ) then +C w = w + MAX(M,P) + N*(P+M); +C end +C end +C if ( JOBE = 'E' or DICO = 'D' or JOBD = 'D' ) then +C w = MAX( w, r + 6*N + (2*N+P+M)*(2*N+P+M) + +C MAX( 2*(N+P+M), 8*N*N + 16*N ) ); +C end +C K = MAX( 1, K, w, r + 2*N + e ); +C end +C +C For good performance, LDWORK must generally be larger. +C +C An easily computable upper bound is +C +C K = MAX( 1, 15*N*N + P*P + M*M + (6*N+3)*(P+M) + 4*P*M + +C N*M + 22*N + 7*MIN(P,M) ). +C +C The smallest workspace is obtained for DICO = 'C', +C JOBE = 'I', and JOBD = 'Z', namely +C +C K = MAX( 1, N*N + N*P + N*M + N + +C MAX( N*N + N*M + P*M + 3*N + c, +C 4*N*N + 10*N ) ). +C +C for which an upper bound is +C +C K = MAX( 1, 6*N*N + N*P + 2*N*M + P*M + 11*N + MAX(P,M) + +C 6*MIN(P,M) ). +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) contains the optimal +C LCWORK. +C +C LCWORK INTEGER +C The dimension of the array CWORK. +C LCWORK >= 1, if N = 0, or B = 0, or C = 0; +C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), +C otherwise. +C For good performance, LCWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix E is (numerically) singular; +C = 2: the (periodic) QR (or QZ) algorithm for computing +C eigenvalues did not converge; +C = 3: the SVD algorithm for computing singular values did +C not converge; +C = 4: the tolerance is too small and the algorithm did +C not converge. +C +C METHOD +C +C The routine implements the method presented in [1], with +C extensions and refinements for improving numerical robustness and +C efficiency. Structure-exploiting eigenvalue computations for +C Hamiltonian matrices are used if JOBE = 'I', DICO = 'C', and the +C symmetric matrices to be implicitly inverted are not too ill- +C conditioned. Otherwise, generalized eigenvalue computations are +C used in the iterative algorithm of [1]. +C +C REFERENCES +C +C [1] Bruinsma, N.A. and Steinbuch, M. +C A fast algorithm to compute the Hinfinity-norm of a transfer +C function matrix. +C Systems & Control Letters, vol. 14, pp. 287-293, 1990. +C +C NUMERICAL ASPECTS +C +C If the algorithm does not converge in MAXIT = 30 iterations +C (INFO = 4), the tolerance must be increased. +C +C FURTHER COMMENTS +C +C If the matrix E is singular, other SLICOT Library routines +C could be used before calling AB13DD, for removing the singular +C part of the system. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C Partly based on SLICOT Library routine AB13CD by P.Hr. Petkov, +C D.W. Gu and M.M. Konstantinov. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C May 2003, Aug. 2005, March 2008, May 2009, Sep. 2009. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, system norm. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, P25 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, P25 = 0.25D+0 ) + DOUBLE PRECISION TEN, HUNDRD, THOUSD + PARAMETER ( TEN = 1.0D+1, HUNDRD = 1.0D+2, + $ THOUSD = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBD, JOBE + INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, + $ M, N, P + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + COMPLEX*16 CWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), E( LDE, * ), + $ FPEAK( 2 ), GPEAK( 2 ) + INTEGER IWORK( * ) +C .. +C .. Local Scalars .. + CHARACTER VECT + LOGICAL DISCR, FULLE, ILASCL, ILESCL, LEQUIL, NODYN, + $ USEPEN, WITHD + INTEGER I, IA, IAR, IAS, IB, IBS, IBT, IBV, IC, ICU, + $ ID, IE, IERR, IES, IH, IH12, IHI, II, ILO, IM, + $ IMIN, IPA, IPE, IR, IS, ISB, ISC, ISL, ITAU, + $ ITER, IU, IV, IWRK, J, K, LW, MAXCWK, MAXWRK, + $ MINCWR, MINPM, MINWRK, N2, N2PM, NEI, NN, NWS, + $ NY, PM + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNORM, BOUND, CNORM, + $ ENRM, ENRMTO, EPS, FPEAKI, FPEAKS, GAMMA, + $ GAMMAL, GAMMAS, MAXRED, OMEGA, PI, RAT, RCOND, + $ RTOL, SAFMAX, SAFMIN, SMLNUM, TM, TOLER, WMAX, + $ WRMIN +C .. +C .. Local Arrays .. + DOUBLE PRECISION TEMP( 1 ) +C .. +C .. External Functions .. + DOUBLE PRECISION AB13DX, DLAMCH, DLANGE, DLAPY2 + LOGICAL LSAME + EXTERNAL AB13DX, DLAMCH, DLANGE, DLAPY2, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEHRD, DGEMM, DGEQRF, DGESVD, + $ DGGBAL, DGGEV, DHGEQZ, DHSEQR, DLABAD, DLACPY, + $ DLASCL, DLASRT, DORGQR, DORMHR, DSWAP, DSYRK, + $ DTRCON, MA02AD, MB01SD, MB03XD, TB01ID, TG01AD, + $ TG01BD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, ATAN, ATAN2, COS, DBLE, INT, LOG, MAX, + $ MIN, SIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + N2 = 2*N + NN = N*N + PM = P + M + N2PM = N2 + PM + MINPM = MIN( P, M ) + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + FULLE = LSAME( JOBE, 'G' ) + LEQUIL = LSAME( EQUIL, 'S' ) + WITHD = LSAME( JOBD, 'D' ) +C + IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( MIN( FPEAK( 1 ), FPEAK( 2 ) ).LT.ZERO ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -18 + ELSE IF( TOL.LT.ZERO .OR. TOL.GE.ONE ) THEN + INFO = -20 + ELSE + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) + NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO + USEPEN = FULLE .OR. DISCR +C +C Compute workspace. +C + ID = 6*MINPM + IC = MAX( 4*MINPM + MAX( P, M ), ID ) + IF( MINPM.EQ.0 ) THEN + MINWRK = 1 + ELSE IF( NODYN ) THEN + IF( WITHD ) THEN + MINWRK = P*M + IC + ELSE + MINWRK = 1 + END IF + ELSE + IF ( DISCR ) THEN + IB = 0 + IE = ID + ELSE + IB = N*( N + M ) + IF ( .NOT.WITHD ) + $ IB = IB + P*M + IE = IC + END IF + IF ( WITHD ) THEN + IR = P*M + IF ( .NOT.USEPEN ) THEN + MINWRK = P*P + M*M + IR = IR + N*PM + ELSE + MINWRK = 0 + END IF + MINWRK = MINWRK + IR + IC + IR = IR + MINPM + ELSE + IR = 0 + MINWRK = 0 + END IF + IR = IR + N*( N + PM ) + IF ( FULLE ) THEN + IR = IR + NN + IF ( LEQUIL ) + $ MINWRK = MAX( MINWRK, IR + 9*N ) + MINWRK = MAX( MINWRK, IR + 4*N + MAX( M, 2*NN, + $ N + IB + IE ) ) + ELSE + MINWRK = MAX( MINWRK, IR + N + MAX( M, P, NN + N2, + $ 3*N + IB + IE ) ) + END IF + LW = 0 + IF ( .NOT.USEPEN ) THEN + LW = IR + 4*NN + 11*N + IF ( WITHD ) + $ LW = LW + MAX( M, P ) + N*PM + END IF + IF ( USEPEN .OR. WITHD ) + $ LW = MAX( LW, IR + 6*N + N2PM*N2PM + + $ MAX( N2PM + PM, 8*( NN + N2 ) ) ) + MINWRK = MAX( 1, MINWRK, LW, IR + N2 + IE ) + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -23 + ELSE + IF ( NODYN ) THEN + MINCWR = 1 + ELSE + MINCWR = MAX( 1, ( N + M )*( N + P ) + + $ 2*MINPM + MAX( P, M ) ) + END IF + IF( LCWORK.LT.MINCWR ) + $ INFO = -25 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. P.EQ.0 ) THEN + GPEAK( 1 ) = ZERO + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + DWORK( 1 ) = ONE + CWORK( 1 ) = ONE + RETURN + END IF +C +C Determine the maximum singular value of G(infinity) = D . +C If JOBE = 'I' and DICO = 'C', the full SVD of D, D = U*S*V', is +C computed and saved for later use. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + ID = 1 + IF ( WITHD ) THEN + IS = ID + P*M + IF ( USEPEN .OR. NODYN ) THEN + IU = IS + MINPM + IV = IU + IWRK = IV + VECT = 'N' + ELSE + IBV = IS + MINPM + ICU = IBV + N*M + IU = ICU + P*N + IV = IU + P*P + IWRK = IV + M*M + VECT = 'A' + END IF +C +C Workspace: need P*M + MIN(P,M) + V + +C MAX( 3*MIN(P,M) + MAX(P,M), 5*MIN(P,M) ), +C where V = N*(M+P) + P*P + M*M, +C if JOBE = 'I' and DICO = 'C', +C and N > 0, B <> 0, C <> 0, +C V = 0, otherwise; +C prefer larger. +C + CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + CALL DGESVD( VECT, VECT, P, M, DWORK( ID ), P, DWORK( IS ), + $ DWORK( IU ), P, DWORK( IV ), M, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + GAMMAL = DWORK( IS ) + MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Restore D for later calculations. +C + CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + ELSE + IWRK = 1 + GAMMAL = ZERO + MAXWRK = 1 + END IF +C +C Quick return if possible. +C + IF( NODYN ) THEN + GPEAK( 1 ) = GAMMAL + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = ONE + RETURN + END IF +C + IF ( .NOT.USEPEN .AND. WITHD ) THEN +C +C Standard continuous-time case, D <> 0: Compute B*V and C'*U . +C + CALL DGEMM( 'No Transpose', 'Transpose', N, M, M, ONE, B, LDB, + $ DWORK( IV ), M, ZERO, DWORK( IBV ), N ) + CALL DGEMM( 'Transpose', 'No Transpose', N, P, P, ONE, C, + $ LDC, DWORK( IU ), P, ZERO, DWORK( ICU ), N ) +C +C U and V are no longer needed: free their memory space. +C Total workspace here: need P*M + MIN(P,M) + N*(M+P) +C (JOBE = 'I', DICO = 'C', JOBD = 'D'). +C + IWRK = IU + END IF +C +C Get machine constants. +C + EPS = DLAMCH( 'Epsilon' ) + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + TOLER = SQRT( EPS ) +C +C Initiate the transformation of the system to an equivalent one, +C to be used for eigenvalue computations. +C +C Additional workspace: need N*N + N*M + P*N + 2*N, if JOBE = 'I'; +C 2*N*N + N*M + P*N + 2*N, if JOBE = 'G'. +C + IA = IWRK + IE = IA + NN + IF ( FULLE ) THEN + IB = IE + NN + ELSE + IB = IE + END IF + IC = IB + N*M + IR = IC + P*N + II = IR + N + IBT = II + N +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IA ), N ) + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IB ), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK( IC ), P ) +C +C Scale A if maximum element is outside the range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'Max', N, N, DWORK( IA ), N, DWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'General', 0, 0, ANRM, ANRMTO, N, N, DWORK( IA ), + $ N, IERR ) +C + IF ( FULLE ) THEN +C +C Descriptor system. +C +C Additional workspace: need N. +C + IWRK = IBT + N + CALL DLACPY( 'Full', N, N, E, LDE, DWORK( IE ), N ) +C +C Scale E if maximum element is outside the range +C [SMLNUM,BIGNUM]. +C + ENRM = DLANGE( 'Max', N, N, DWORK( IE ), N, DWORK ) + ILESCL = .FALSE. + IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN + ENRMTO = SMLNUM + ILESCL = .TRUE. + ELSE IF( ENRM.GT.BIGNUM ) THEN + ENRMTO = BIGNUM + ILESCL = .TRUE. + ELSE IF( ENRM.EQ.ZERO ) THEN +C +C Error return: Matrix E is 0. +C + INFO = 1 + RETURN + END IF + IF( ILESCL ) + $ CALL DLASCL( 'General', 0, 0, ENRM, ENRMTO, N, N, + $ DWORK( IE ), N, IERR ) +C +C Equilibrate the system, if required. +C +C Additional workspace: need 6*N. +C + IF( LEQUIL ) + $ CALL TG01AD( 'All', N, N, M, P, ZERO, DWORK( IA ), N, + $ DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), P, + $ DWORK( II ), DWORK( IR ), DWORK( IWRK ), + $ IERR ) +C +C For efficiency of later calculations, the system (A,E,B,C) is +C reduced to an equivalent one with the state matrix A in +C Hessenberg form, and E upper triangular. +C First, permute (A,E) to make it more nearly triangular. +C + CALL DGGBAL( 'Permute', N, DWORK( IA ), N, DWORK( IE ), N, ILO, + $ IHI, DWORK( II ), DWORK( IR ), DWORK( IWRK ), + $ IERR ) +C +C Apply the permutations to (the copies of) B and C. +C + DO 10 I = N, IHI + 1, -1 + K = DWORK( II+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + K = DWORK( IR+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + 10 CONTINUE +C + DO 20 I = 1, ILO - 1 + K = DWORK( II+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + K = DWORK( IR+I-1 ) + IF( K.NE.I ) + $ CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + 20 CONTINUE +C +C Reduce (A,E) to generalized Hessenberg form and apply the +C transformations to B and C. +C Additional workspace: need N + MAX(N,M); +C prefer N + MAX(N,M)*NB. +C + CALL TG01BD( 'General', 'No Q', 'No Z', N, M, P, ILO, IHI, + $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), N, + $ DWORK( IC ), P, DWORK, 1, DWORK, 1, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Check whether matrix E is nonsingular. +C Additional workspace: need 3*N. +C + CALL DTRCON( '1-norm', 'Upper', 'Non Unit', N, DWORK( IE ), N, + $ RCOND, DWORK( IWRK ), IWORK, IERR ) + IF( RCOND.LE.TEN*DBLE( N )*EPS ) THEN +C +C Error return: Matrix E is numerically singular. +C + INFO = 1 + RETURN + END IF +C +C Perform QZ algorithm, computing eigenvalues. The generalized +C Hessenberg form is saved for later use. +C Additional workspace: need 2*N*N + N; +C prefer larger. +C + IAS = IWRK + IES = IAS + NN + IWRK = IES + NN + CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DLACPY( 'Full', N, N, DWORK( IE ), N, DWORK( IES ), N ) + CALL DHGEQZ( 'Eigenvalues', 'No Vectors', 'No Vectors', N, ILO, + $ IHI, DWORK( IAS ), N, DWORK( IES ), N, + $ DWORK( IR ), DWORK( II ), DWORK( IBT ), DWORK, N, + $ DWORK, N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Check if unscaling would cause over/underflow; if so, rescale +C eigenvalues (DWORK( IR+I-1 ),DWORK( II+I-1 ),DWORK( IBT+I-1 )) +C so DWORK( IBT+I-1 ) is on the order of E(I,I) and +C DWORK( IR+I-1 ) and DWORK( II+I-1 ) are on the order of A(I,I). +C + IF( ILASCL ) THEN +C + DO 30 I = 1, N + IF( DWORK( II+I-1 ).NE.ZERO ) THEN + IF( ( DWORK( IR+I-1 ) / SAFMAX ).GT.( ANRMTO / ANRM ) + $ .OR. + $ ( SAFMIN / DWORK( IR+I-1 ) ).GT.( ANRM / ANRMTO ) + $ ) THEN + TM = ABS( DWORK( IA+(I-1)*N+I ) / DWORK( IR+I-1 ) ) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + ELSE IF( ( DWORK( II+I-1 ) / SAFMAX ).GT. + $ ( ANRMTO / ANRM ) .OR. + $ ( SAFMIN / DWORK( II+I-1 ) ).GT.( ANRM / ANRMTO ) ) + $ THEN + TM = ABS( DWORK( IA+I*N+I ) / DWORK( II+I-1 ) ) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + END IF + END IF + 30 CONTINUE +C + END IF +C + IF( ILESCL ) THEN +C + DO 40 I = 1, N + IF( DWORK( II+I-1 ).NE.ZERO ) THEN + IF( ( DWORK( IBT+I-1 ) / SAFMAX ).GT.( ENRMTO / ENRM ) + $ .OR. + $ ( SAFMIN / DWORK( IBT+I-1 ) ).GT.( ENRM / ENRMTO ) + $ ) THEN + TM = ABS( DWORK( IE+(I-1)*N+I ) / DWORK( IBT+I-1 )) + DWORK( IBT+I-1 ) = DWORK( IBT+I-1 )*TM + DWORK( IR+I-1 ) = DWORK( IR+I-1 )*TM + DWORK( II+I-1 ) = DWORK( II+I-1 )*TM + END IF + END IF + 40 CONTINUE +C + END IF +C +C Undo scaling. +C + IF( ILASCL ) THEN + CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, + $ DWORK( IA ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( IR ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( II ), N, IERR ) + END IF +C + IF( ILESCL ) THEN + CALL DLASCL( 'Upper', 0, 0, ENRMTO, ENRM, N, N, + $ DWORK( IE ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ENRMTO, ENRM, N, 1, + $ DWORK( IBT ), N, IERR ) + END IF +C + ELSE +C +C Standard state-space system. +C + IF( LEQUIL ) THEN +C +C Equilibrate the system. +C + MAXRED = HUNDRD + CALL TB01ID( 'All', N, M, P, MAXRED, DWORK( IA ), N, + $ DWORK( IB ), N, DWORK( IC ), P, DWORK( II ), + $ IERR ) + END IF +C +C For efficiency of later calculations, the system (A,B,C) is +C reduced to a similar one with the state matrix in Hessenberg +C form. +C +C First, permute the matrix A to make it more nearly triangular +C and apply the permutations to B and C. +C + CALL DGEBAL( 'Permute', N, DWORK( IA ), N, ILO, IHI, + $ DWORK( IR ), IERR ) +C + DO 50 I = N, IHI + 1, -1 + K = DWORK( IR+I-1 ) + IF( K.NE.I ) THEN + CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + END IF + 50 CONTINUE +C + DO 60 I = 1, ILO - 1 + K = DWORK( IR+I-1 ) + IF( K.NE.I ) THEN + CALL DSWAP( M, DWORK( IB+I-1 ), N, + $ DWORK( IB+K-1 ), N ) + CALL DSWAP( P, DWORK( IC+(I-1)*P ), 1, + $ DWORK( IC+(K-1)*P ), 1 ) + END IF + 60 CONTINUE +C +C Reduce A to upper Hessenberg form and apply the transformations +C to B and C. +C Additional workspace: need N; (from II) +C prefer N*NB. +C + ITAU = IR + IWRK = ITAU + N + CALL DGEHRD( N, ILO, IHI, DWORK( IA ), N, DWORK( ITAU ), + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need M; +C prefer M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, DWORK( IA ), + $ N, DWORK( ITAU ), DWORK( IB ), N, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need P; +C prefer P*NB. +C + CALL DORMHR( 'Right', 'NoTranspose', P, N, ILO, IHI, + $ DWORK( IA ), N, DWORK( ITAU ), DWORK( IC ), P, + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Compute the eigenvalues. The Hessenberg form is saved for +C later use. +C Additional workspace: need N*N + N; (from IBT) +C prefer larger. +C + IAS = IBT + IWRK = IAS + NN + CALL DLACPY( 'Full', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DHSEQR( 'Eigenvalues', 'No Vectors', N, ILO, IHI, + $ DWORK( IAS ), N, DWORK( IR ), DWORK( II ), DWORK, + $ N, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C + IF( ILASCL ) THEN +C +C Undo scaling for the Hessenberg form of A and eigenvalues. +C + CALL DLASCL( 'Hessenberg', 0, 0, ANRMTO, ANRM, N, N, + $ DWORK( IA ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( IR ), N, IERR ) + CALL DLASCL( 'General', 0, 0, ANRMTO, ANRM, N, 1, + $ DWORK( II ), N, IERR ) + END IF +C + END IF +C +C Look for (generalized) eigenvalues on the boundary of the +C stability domain. (Their existence implies an infinite norm.) +C Additional workspace: need 2*N. (from IAS) +C + IM = IAS + IAR = IM + N + IMIN = II + WRMIN = SAFMAX + BOUND = EPS*THOUSD +C + IF ( DISCR ) THEN + GAMMAL = ZERO +C +C For discrete-time case, compute the logarithm of the non-zero +C eigenvalues and save their moduli and absolute real parts. +C (The logarithms are overwritten on the eigenvalues.) +C Also, find the minimum distance to the unit circle. +C + IF ( FULLE ) THEN +C + DO 70 I = 0, N - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. SAFMAX is used. +C + TM = SAFMAX + END IF + IF ( TM.NE.ZERO ) THEN + DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) + DWORK( IR+I ) = LOG( TM ) + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + TM = ABS( ONE - TM ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + IM = IM + 1 + DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) + 70 CONTINUE +C + ELSE +C + DO 80 I = 0, N - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( TM.NE.ZERO ) THEN + DWORK( II+I ) = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) + DWORK( IR+I ) = LOG( TM ) + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + TM = ABS( ONE - TM ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + IM = IM + 1 + DWORK( IAR+I ) = ABS( DWORK( IR+I ) ) + 80 CONTINUE +C + END IF +C + ELSE +C +C For continuous-time case, save moduli of eigenvalues and +C absolute real parts and find the maximum modulus and minimum +C absolute real part. +C + WMAX = ZERO +C + IF ( FULLE ) THEN +C + DO 90 I = 0, N - 1 + TM = ABS( DWORK( IR+I ) ) + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ DWORK( IM ).LT.SAFMAX*DWORK( IBT+I ) ) ) + $ THEN + TM = TM / DWORK( IBT+I ) + DWORK( IM ) = DWORK( IM ) / DWORK( IBT+I ) + ELSE + IF ( TM.LT.SAFMAX*DWORK( IBT+I ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. +C SAFMAX is used. +C + TM = SAFMAX + END IF + DWORK( IM ) = SAFMAX + END IF + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + DWORK( IAR+I ) = TM + IF( DWORK( IM ).GT.WMAX ) + $ WMAX = DWORK( IM ) + IM = IM + 1 + 90 CONTINUE +C + ELSE +C + DO 100 I = 0, N - 1 + TM = ABS( DWORK( IR+I ) ) + IF( TM.LT.WRMIN ) THEN + IMIN = II + I + WRMIN = TM + END IF + DWORK( IM ) = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF( DWORK( IM ).GT.WMAX ) + $ WMAX = DWORK( IM ) + IM = IM + 1 + DWORK( IAR+I ) = TM + 100 CONTINUE +C + END IF +C + BOUND = BOUND + EPS*WMAX +C + END IF +C + IM = IM - N +C + IF( WRMIN.LT.BOUND ) THEN +C +C The L-infinity norm was found as infinite. +C + GPEAK( 1 ) = ONE + GPEAK( 2 ) = ZERO + TM = ABS( DWORK( IMIN ) ) + IF ( DISCR ) + $ TM = ABS( ATAN2( SIN( TM ), COS( TM ) ) ) + FPEAK( 1 ) = TM + IF ( TM.LT.SAFMAX ) THEN + FPEAK( 2 ) = ONE + ELSE + FPEAK( 2 ) = ZERO + END IF +C + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = ONE + RETURN + END IF +C +C Determine the maximum singular value of +C G(lambda) = C*inv(lambda*E - A)*B + D, +C over a selected set of frequencies. Besides the frequencies w = 0, +C w = pi (if DICO = 'D'), and the given value FPEAK, this test set +C contains the peak frequency for each mode (or an approximation +C of it). The (generalized) Hessenberg form of the system is used. +C +C First, determine the maximum singular value of G(0) and set FPEAK +C accordingly. +C Additional workspace: +C complex: need 1, if DICO = 'C'; +C (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)), otherwise; +C prefer larger; +C real: need LDW0+LDW1+LDW2, where +C LDW0 = N*N+N*M, if DICO = 'C'; +C LDW0 = 0, if DICO = 'D'; +C LDW1 = P*M, if DICO = 'C', JOBD = 'Z'; +C LDW1 = 0, otherwise; +C LDW2 = MIN(P,M)+MAX(3*MIN(P,M)+MAX(P,M), +C 5*MIN(P,M)), +C if DICO = 'C'; +C LDW2 = 6*MIN(P,M), otherwise. +C prefer larger. +C + IF ( DISCR ) THEN + IAS = IA + IBS = IB + IWRK = IAR + N + ELSE + IAS = IAR + N + IBS = IAS + NN + IWRK = IBS + N*M + CALL DLACPY( 'Upper', N, N, DWORK( IA ), N, DWORK( IAS ), N ) + CALL DCOPY( N-1, DWORK( IA+1 ), N+1, DWORK( IAS+1 ), N+1 ) + CALL DLACPY( 'Full', N, M, DWORK( IB ), N, DWORK( IBS ), N ) + END IF + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, ZERO, DWORK( IAS ), N, + $ DWORK( IE ), N, DWORK( IBS ), N, DWORK( IC ), P, + $ DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + FPEAKS = FPEAK( 1 ) + FPEAKI = FPEAK( 2 ) + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = ZERO + FPEAK( 2 ) = ONE + ELSE IF( .NOT.DISCR ) THEN + FPEAK( 1 ) = ONE + FPEAK( 2 ) = ZERO + END IF +C + MAXCWK = INT( CWORK( 1 ) ) +C + IF( DISCR ) THEN +C +C Try the frequency w = pi. +C + PI = FOUR*ATAN( ONE ) + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, PI, DWORK( IA ), + $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), + $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = PI + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = PI + FPEAK( 2 ) = ONE + END IF +C + ELSE + IWRK = IAS +C +C Restore D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', P, M, D, LDD, DWORK( ID ), P ) + END IF +C +C Build the remaining set of frequencies. +C Complex workspace: need (N+M)*(N+P)+2*MIN(P,M)+MAX(P,M)); +C prefer larger. +C Real workspace: need LDW2, see above; +C prefer larger. +C + IF ( MIN( FPEAKS, FPEAKI ).NE.ZERO ) THEN +C +C Compute also the norm at the given (finite) frequency. +C + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, FPEAKS, DWORK( IA ), + $ N, DWORK( IE ), N, DWORK( IB ), N, DWORK( IC ), + $ P, DWORK( ID ), P, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, CWORK, LCWORK, IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF ( DISCR ) THEN + TM = ABS( ATAN2( SIN( FPEAKS ), COS( FPEAKS ) ) ) + ELSE + TM = FPEAKS + END IF + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = TM + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = TM + FPEAK( 2 ) = ONE + END IF +C + END IF +C + DO 110 I = 0, N - 1 + IF( DWORK( II+I ).GE.ZERO .AND. DWORK( IM+I ).GT.ZERO ) THEN + IF ( ( DWORK( IM+I ).GE.ONE ) .OR. ( DWORK( IM+I ).LT.ONE + $ .AND. DWORK( IAR+I ).LT.SAFMAX*DWORK( IM+I ) ) ) THEN + RAT = DWORK( IAR+I ) / DWORK( IM+I ) + ELSE + RAT = ONE + END IF + OMEGA = DWORK( IM+I )*SQRT( MAX( P25, ONE - TWO*RAT**2 ) ) +C + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, + $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), + $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, + $ IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF ( DISCR ) THEN + TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) + ELSE + TM = OMEGA + END IF + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = TM + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = TM + FPEAK( 2 ) = ONE + END IF +C + END IF + 110 CONTINUE +C +C Return if the lower bound is zero. +C + IF( GAMMAL.EQ.ZERO ) THEN + GPEAK( 1 ) = ZERO + FPEAK( 1 ) = ZERO + GPEAK( 2 ) = ONE + FPEAK( 2 ) = ONE + GO TO 340 + END IF +C +C Start the modified gamma iteration for the Bruinsma-Steinbuch +C algorithm. +C + IF ( .NOT.DISCR ) + $ RTOL = HUNDRD*TOLER + ITER = 0 +C +C WHILE ( Iteration may continue ) DO +C + 120 CONTINUE +C + ITER = ITER + 1 + GAMMA = ( ONE + TOL )*GAMMAL + USEPEN = FULLE .OR. DISCR + IF ( .NOT.USEPEN .AND. WITHD ) THEN +C +C Check whether one can use an explicit Hamiltonian matrix: +C compute +C min(rcond(GAMMA**2*Im - S'*S), rcond(GAMMA**2*Ip - S*S')). +C If P = M = 1, then GAMMA**2 - S(1)**2 is used instead. +C + IF ( M.NE.P ) THEN + RCOND = ONE - ( DWORK( IS ) / GAMMA )**2 + ELSE IF ( MINPM.GT.1 ) THEN + RCOND = ( GAMMA**2 - DWORK( IS )**2 ) / + $ ( GAMMA**2 - DWORK( IS+P-1 )**2 ) + ELSE + RCOND = GAMMA**2 - DWORK( IS )**2 + END IF +C + USEPEN = RCOND.LT.RTOL + END IF +C + IF ( USEPEN ) THEN +C +C Use the QZ algorithm on a pencil. +C Additional workspace here: need 6*N. (from IR) +C + II = IR + N2 + IBT = II + N2 + IH12 = IBT + N2 + IM = IH12 +C +C Set up the needed parts of the Hamiltonian pencil (H,J), +C +C ( H11 H12 ) +C H = ( ) , +C ( H21 H22 ) +C +C with +C +C ( A 0 ) ( 0 B ) ( E 0 ) +C H11 = ( ), H12 = ( )/nB, J11 = ( ), +C ( 0 -A' ) ( C' 0 ) ( 0 E' ) +C +C ( C 0 ) ( Ip D/g ) +C H21 = ( )*nB, H22 = ( ), +C ( 0 -B' ) ( D'/g Im ) +C +C if DICO = 'C', and +C +C ( A 0 ) ( B 0 ) ( E 0 ) +C H11 = ( ), H12 = ( )/nB, J11 = ( ), +C ( 0 E' ) ( 0 C' ) ( 0 A') +C +C ( 0 0 ) ( Im D'/g ) ( 0 B') +C H21 = ( )*nB, H22 = ( ), J21 = ( )*nB, +C ( C 0 ) ( D/g Ip ) ( 0 0 ) +C +C if DICO = 'D', where g = GAMMA, and nB = norm(B,1). +C First build [H12; H22]. +C + TEMP( 1 ) = ZERO + IH = IH12 +C + IF ( DISCR ) THEN +C + DO 150 J = 1, M +C + DO 130 I = 1, N + DWORK( IH ) = B( I, J ) / BNORM + IH = IH + 1 + 130 CONTINUE +C + CALL DCOPY( N+M, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+N+J-1 ) = ONE + IH = IH + N + M +C + DO 140 I = 1, P + DWORK( IH ) = D( I, J ) / GAMMA + IH = IH + 1 + 140 CONTINUE +C + 150 CONTINUE +C + DO 180 J = 1, P + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 160 I = 1, N + DWORK( IH ) = C( J, I ) / BNORM + IH = IH + 1 + 160 CONTINUE +C + DO 170 I = 1, M + DWORK( IH ) = D( J, I ) / GAMMA + IH = IH + 1 + 170 CONTINUE +C + CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + P + 180 CONTINUE +C + ELSE +C + DO 210 J = 1, P + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 190 I = 1, N + DWORK( IH ) = C( J, I ) / BNORM + IH = IH + 1 + 190 CONTINUE +C + CALL DCOPY( P, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + P +C + DO 200 I = 1, M + DWORK( IH ) = D( J, I ) / GAMMA + IH = IH + 1 + 200 CONTINUE +C + 210 CONTINUE +C + DO 240 J = 1, M +C + DO 220 I = 1, N + DWORK( IH ) = B( I, J ) / BNORM + IH = IH + 1 + 220 CONTINUE +C + CALL DCOPY( N, TEMP, 0, DWORK( IH ), 1 ) + IH = IH + N +C + DO 230 I = 1, P + DWORK( IH ) = D( I, J ) / GAMMA + IH = IH + 1 + 230 CONTINUE +C + CALL DCOPY( M, TEMP, 0, DWORK( IH ), 1 ) + DWORK( IH+J-1 ) = ONE + IH = IH + M + 240 CONTINUE +C + END IF +C +C Compute the QR factorization of [H12; H22]. +C For large P and M, it could be more efficient to exploit the +C structure of [H12; H22] and use the factored form of Q. +C Additional workspace: need (2*N+P+M)*(2*N+P+M)+2*(P+M); +C prefer (2*N+P+M)*(2*N+P+M)+P+M+ +C (P+M)*NB. +C + ITAU = IH12 + N2PM*N2PM + IWRK = ITAU + PM + CALL DGEQRF( N2PM, PM, DWORK( IH12 ), N2PM, DWORK( ITAU ), + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Apply part of the orthogonal transformation: +C Q1 = Q(:,P+M+(1:2*N))' to the matrix [H11; H21/GAMMA]. +C If DICO = 'C', apply Q(1:2*N,P+M+(1:2*N))' to the +C matrix J11. +C If DICO = 'D', apply Q1 to the matrix [J11; J21/GAMMA]. +C H11, H21, J11, and J21 are not fully built. +C First, build the (2*N+P+M)-by-(2*N+P+M) matrix Q. +C Using Q will often provide better efficiency than the direct +C use of the factored form of Q, especially when P+M < N. +C Additional workspace: need P+M+2*N+P+M; +C prefer P+M+(2*N+P+M)*NB. +C + CALL DORGQR( N2PM, N2PM, PM, DWORK( IH12 ), N2PM, + $ DWORK( ITAU ), DWORK( IWRK ), LDWORK-IWRK+1, + $ IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C +C Additional workspace: need 8*N*N. +C + IPA = ITAU + IPE = IPA + 4*NN + IWRK = IPE + 4*NN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM ), N2PM, A, LDA, ZERO, + $ DWORK( IPA ), N2 ) + IF ( DISCR ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, + $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+M), N2PM, + $ C, LDC, ONE, DWORK( IPA ), N2 ) + IF ( FULLE ) THEN + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, + $ ZERO, DWORK( IPA+2*NN ), N2 ) + ELSE + CALL MA02AD( 'Full', N, N2, DWORK( IH12+PM*N2PM+N ), + $ N2PM, DWORK( IPA+2*NN ), N2 ) + NY = N + END IF + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, P, + $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2), N2PM, + $ C, LDC, ONE, DWORK( IPA ), N2 ) + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, -ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, ZERO, + $ DWORK( IPA+2*NN ), N2 ) + CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, + $ -BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2+P), + $ N2PM, B, LDB, ONE, DWORK( IPA+2*NN ), N2 ) + NY = N2 + END IF +C + IF ( FULLE ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM ), N2PM, E, LDE, ZERO, + $ DWORK( IPE ), N2 ) + ELSE + CALL MA02AD( 'Full', NY, N2, DWORK( IH12+PM*N2PM ), + $ N2PM, DWORK( IPE ), N2 ) + END IF + IF ( DISCR ) THEN + CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, A, LDA, + $ ZERO, DWORK( IPE+2*NN ), N2 ) + CALL DGEMM( 'Transpose', 'Transpose', N2, N, M, + $ BNORM/GAMMA, DWORK( IH12+PM*N2PM+N2 ), N2PM, + $ B, LDB, ONE, DWORK( IPE+2*NN ), N2 ) + ELSE + IF ( FULLE ) + $ CALL DGEMM( 'Transpose', 'Transpose', N2, N, N, ONE, + $ DWORK( IH12+PM*N2PM+N ), N2PM, E, LDE, + $ ZERO, DWORK( IPE+2*NN ), N2 ) + END IF +C +C Compute the eigenvalues of the Hamiltonian pencil. +C Additional workspace: need 16*N; +C prefer larger. +C + CALL DGGEV( 'No Vectors', 'No Vectors', N2, DWORK( IPA ), + $ N2, DWORK( IPE ), N2, DWORK( IR ), DWORK( II ), + $ DWORK( IBT ), DWORK, N2, DWORK, N2, + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C + ELSE IF ( .NOT.WITHD ) THEN +C +C Standard continuous-time case with D = 0. +C Form the needed part of the Hamiltonian matrix explicitly: +C H = H11 - H12*inv(H22)*H21/g. +C Additional workspace: need 2*N*N+N. (from IBT) +C + IH = IBT + IH12 = IH + NN + ISL = IH12 + NN + N + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) +C +C Compute triangles of -C'*C/GAMMA and B*B'/GAMMA. +C + CALL DSYRK( 'Lower', 'Transpose', N, P, -ONE/GAMMA, C, LDC, + $ ZERO, DWORK( IH12 ), N ) + CALL DSYRK( 'Upper', 'No Transpose', N, M, ONE/GAMMA, B, + $ LDB, ZERO, DWORK( IH12+N ), N ) +C + ELSE +C +C Standard continuous-time case with D <> 0 and the SVD of D +C can be used. Compute explicitly the needed part of the +C Hamiltonian matrix: +C +C (A+B1*S'*inv(g^2*Ip-S*S')*C1' g*B1*inv(g^2*Im-S'*S)*B1') +C H = ( ) +C ( -g*C1*inv(g^2*Ip-S*S')*C1' -H11' ) +C +C where g = GAMMA, B1 = B*V, C1 = C'*U, and H11 is the first +C block of H. +C Primary additional workspace: need 2*N*N+N (from IBT) +C (for building the relevant part of the Hamiltonian matrix). +C +C Compute C1*sqrt(inv(g^2*Ip-S*S')) . +C Additional workspace: need MAX(M,P)+N*P. +C + IH = IBT + IH12 = IH + NN + ISL = IH12 + NN + N +C + DO 250 I = 0, MINPM - 1 + DWORK( ISL+I ) = ONE/SQRT( GAMMA**2 - DWORK( IS+I )**2 ) + 250 CONTINUE +C + IF ( M.LT.P ) THEN + DWORK( ISL+M ) = ONE / GAMMA + CALL DCOPY( P-M-1, DWORK( ISL+M ), 0, DWORK( ISL+M+1 ), + $ 1 ) + END IF + ISC = ISL + MAX( M, P ) + CALL DLACPY( 'Full', N, P, DWORK( ICU ), N, DWORK( ISC ), + $ N ) + CALL MB01SD( 'Column', N, P, DWORK( ISC ), N, DWORK, + $ DWORK( ISL ) ) +C +C Compute B1*S' . +C Additional workspace: need N*M. +C + ISB = ISC + P*N + CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), + $ N ) + CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, + $ DWORK( IS ) ) +C +C Compute B1*S'*sqrt(inv(g^2*Ip-S*S')) . +C + CALL MB01SD( 'Column', N, MINPM, DWORK( ISB ), N, DWORK, + $ DWORK( ISL ) ) +C +C Compute H11 . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IH ), N ) + CALL DGEMM( 'No Transpose', 'Transpose', N, N, MINPM, ONE, + $ DWORK( ISB ), N, DWORK( ISC ), N, ONE, + $ DWORK( IH ), N ) +C +C Compute B1*sqrt(inv(g^2*Im-S'*S)) . +C + IF ( P.LT.M ) THEN + DWORK( ISL+P ) = ONE / GAMMA + CALL DCOPY( M-P-1, DWORK( ISL+P ), 0, DWORK( ISL+P+1 ), + $ 1 ) + END IF + CALL DLACPY( 'Full', N, M, DWORK( IBV ), N, DWORK( ISB ), + $ N ) + CALL MB01SD( 'Column', N, M, DWORK( ISB ), N, DWORK, + $ DWORK( ISL ) ) +C +C Compute the lower triangle of H21 and the upper triangle +C of H12. +C + CALL DSYRK( 'Lower', 'No Transpose', N, P, -GAMMA, + $ DWORK( ISC ), N, ZERO, DWORK( IH12 ), N ) + CALL DSYRK( 'Upper', 'No Transpose', N, M, GAMMA, + $ DWORK( ISB ), N, ZERO, DWORK( IH12+N ), N ) + END IF +C + IF ( .NOT.USEPEN ) THEN +C +C Compute the eigenvalues of the Hamiltonian matrix by the +C symplectic URV and the periodic Schur decompositions. +C Additional workspace: need (2*N+8)*N; +C prefer larger. +C + IWRK = ISL + NN + CALL MB03XD( 'Both', 'Eigenvalues', 'No vectors', + $ 'No vectors', N, DWORK( IH ), N, DWORK( IH12 ), + $ N, DWORK( ISL ), N, TEMP, 1, TEMP, 1, TEMP, 1, + $ TEMP, 1, DWORK( IR ), DWORK( II ), ILO, + $ DWORK( IWRK ), DWORK( IWRK+N ), + $ LDWORK-IWRK-N+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK + N - 1, MAXWRK ) + END IF +C +C Detect eigenvalues on the boundary of the stability domain, +C if any. The test is based on a round-off level of eps*rho(H) +C (after balancing) resulting in worst-case perturbations of +C order sqrt(eps*rho(H)), for continuous-time systems, on the +C real part of poles of multiplicity two (typical as GAMMA +C approaches the infinity norm). Similarly, in the discrete-time +C case. Above, rho(H) is the maximum modulus of eigenvalues +C (continuous-time case). +C +C Compute maximum eigenvalue modulus and check the absolute real +C parts (if DICO = 'C'), or moduli (if DICO = 'D'). +C + WMAX = ZERO +C + IF ( USEPEN ) THEN +C +C Additional workspace: need 2*N, if DICO = 'D'; (from IM) +C 0, if DICO = 'C'. +C + DO 260 I = 0, N2 - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. SAFMAX is used. +C + TM = SAFMAX + END IF + WMAX = MAX( WMAX, TM ) + IF ( DISCR ) + $ DWORK( IM+I ) = TM + 260 CONTINUE +C + ELSE +C + DO 270 I = 0, N - 1 + TM = DLAPY2( DWORK( IR+I ), DWORK( II+I ) ) + WMAX = MAX( WMAX, TM ) + 270 CONTINUE +C + END IF +C + NEI = 0 +C + IF ( USEPEN ) THEN +C + DO 280 I = 0, N2 - 1 + IF ( DISCR ) THEN + TM = ABS( ONE - DWORK( IM+I ) ) + ELSE + TM = ABS( DWORK( IR+I ) ) + IF ( ( DWORK( IBT+I ).GE.ONE ) .OR. + $ ( DWORK( IBT+I ).LT.ONE .AND. + $ TM.LT.SAFMAX*DWORK( IBT+I ) ) ) THEN + TM = TM / DWORK( IBT+I ) + ELSE +C +C The pencil has too large eigenvalues. +C SAFMAX is used. +C + TM = SAFMAX + END IF + END IF + IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN + DWORK( IR+NEI ) = DWORK( IR+I ) / DWORK( IBT+I ) + DWORK( II+NEI ) = DWORK( II+I ) / DWORK( IBT+I ) + NEI = NEI + 1 + END IF + 280 CONTINUE +C + ELSE +C + DO 290 I = 0, N - 1 + TM = ABS( DWORK( IR+I ) ) + IF ( TM.LE.TOLER*SQRT( HUNDRD + WMAX ) ) THEN + DWORK( IR+NEI ) = DWORK( IR+I ) + DWORK( II+NEI ) = DWORK( II+I ) + NEI = NEI + 1 + END IF + 290 CONTINUE +C + END IF +C + IF( NEI.EQ.0 ) THEN +C +C There is no eigenvalue on the boundary of the stability +C domain for G = ( ONE + TOL )*GAMMAL. The norm was found. +C + GPEAK( 1 ) = GAMMAL + GPEAK( 2 ) = ONE + GO TO 340 + END IF +C +C Compute the frequencies where the gain G is attained and +C generate new test frequencies. +C + NWS = 0 +C + IF ( DISCR ) THEN +C + DO 300 I = 0, NEI - 1 + TM = ATAN2( DWORK( II+I ), DWORK( IR+I ) ) + DWORK( IR+I ) = MAX( EPS, TM ) + NWS = NWS + 1 + 300 CONTINUE +C + ELSE +C + J = 0 +C + DO 310 I = 0, NEI - 1 + IF ( DWORK( II+I ).GT.EPS ) THEN + DWORK( IR+NWS ) = DWORK( II+I ) + NWS = NWS + 1 + ELSE IF ( DWORK( II+I ).EQ.EPS ) THEN + J = J + 1 + IF ( J.EQ.1 ) THEN + DWORK( IR+NWS ) = EPS + NWS = NWS + 1 + END IF + END IF + 310 CONTINUE +C + END IF +C + CALL DLASRT( 'Increasing', NWS, DWORK( IR ), IERR ) + LW = 1 +C + DO 320 I = 0, NWS - 1 + IF ( DWORK( IR+LW-1 ).NE.DWORK( IR+I ) ) THEN + DWORK( IR+LW ) = DWORK( IR+I ) + LW = LW + 1 + END IF + 320 CONTINUE +C + IF ( LW.EQ.1 ) THEN + IF ( ITER.EQ.1 .AND. NWS.GE.1 ) THEN +C +C Duplicate the frequency trying to force iteration. +C + DWORK( IR+1 ) = DWORK( IR ) + LW = LW + 1 + ELSE +C +C The norm was found. +C + GPEAK( 1 ) = GAMMAL + GPEAK( 2 ) = ONE + GO TO 340 + END IF + END IF +C +C Form the vector of mid-points and compute the gain at new test +C frequencies. Save the current lower bound. +C + IWRK = IR + LW + GAMMAS = GAMMAL +C + DO 330 I = 0, LW - 2 + IF ( DISCR ) THEN + OMEGA = ( DWORK( IR+I ) + DWORK( IR+I+1 ) ) / TWO + ELSE + OMEGA = SQRT( DWORK( IR+I )*DWORK( IR+I+1 ) ) + END IF +C +C Additional workspace: need LDW2, see above; +C prefer larger. +C + GAMMA = AB13DX( DICO, JOBE, JOBD, N, M, P, OMEGA, + $ DWORK( IA ), N, DWORK( IE ), N, DWORK( IB ), + $ N, DWORK( IC ), P, DWORK( ID ), P, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, CWORK, LCWORK, + $ IERR ) + MAXCWK = MAX( INT( CWORK( 1 ) ), MAXCWK ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + IF ( DISCR ) THEN + TM = ABS( ATAN2( SIN( OMEGA ), COS( OMEGA ) ) ) + ELSE + TM = OMEGA + END IF + IF( IERR.GE.1 .AND. IERR.LE.N ) THEN + GPEAK( 1 ) = ONE + FPEAK( 1 ) = TM + GPEAK( 2 ) = ZERO + FPEAK( 2 ) = ONE + GO TO 340 + ELSE IF( IERR.EQ.N+1 ) THEN + INFO = 3 + RETURN + END IF +C + IF( GAMMAL.LT.GAMMA ) THEN + GAMMAL = GAMMA + FPEAK( 1 ) = TM + FPEAK( 2 ) = ONE + END IF + 330 CONTINUE +C +C If the lower bound has not been improved, return. (This is a +C safeguard against undetected modes of Hamiltonian matrix on the +C boundary of the stability domain.) +C + IF ( GAMMAL.LT.GAMMAS*( ONE + TOL/TEN ) ) THEN + GPEAK( 1 ) = GAMMAL + GPEAK( 2 ) = ONE + GO TO 340 + END IF +C +C END WHILE +C + IF ( ITER.LE.MAXIT ) THEN + GO TO 120 + ELSE + INFO = 4 + RETURN + END IF +C + 340 CONTINUE + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = MAXCWK + RETURN +C *** Last line of AB13DD *** + END diff --git a/mex/sources/libslicot/AB13DX.f b/mex/sources/libslicot/AB13DX.f new file mode 100644 index 000000000..09362b7c6 --- /dev/null +++ b/mex/sources/libslicot/AB13DX.f @@ -0,0 +1,544 @@ + DOUBLE PRECISION FUNCTION AB13DX( DICO, JOBE, JOBD, N, M, P, + $ OMEGA, A, LDA, E, LDE, B, LDB, + $ C, LDC, D, LDD, IWORK, DWORK, + $ LDWORK, CWORK, LCWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the maximum singular value of a given continuous-time +C or discrete-time transfer-function matrix, either standard or in +C the descriptor form, +C +C -1 +C G(lambda) = C*( lambda*E - A ) *B + D , +C +C for a given complex value lambda, where lambda = j*omega, in the +C continuous-time case, and lambda = exp(j*omega), in the +C discrete-time case. The matrices A, E, B, C, and D are real +C matrices of appropriate dimensions. Matrix A must be in an upper +C Hessenberg form, and if JOBE ='G', the matrix E must be upper +C triangular. The matrices B and C must correspond to the system +C in (generalized) Hessenberg form. +C +C FUNCTION VALUE +C +C AB13DX DOUBLE PRECISION +C The maximum singular value of G(lambda). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system, as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBE CHARACTER*1 +C Specifies whether E is an upper triangular or an identity +C matrix, as follows: +C = 'G': E is a general upper triangular matrix; +C = 'I': E is the identity matrix. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C P (input) INTEGER +C The row size of the matrix C. P >= 0. +C +C OMEGA (input) DOUBLE PRECISION +C The frequency value for which the calculations should be +C done. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper Hessenberg part of this +C array must contain the state dynamics matrix A in upper +C Hessenberg form. The elements below the subdiagonal are +C not referenced. +C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, +C and C <> 0, the leading N-by-N upper Hessenberg part of +C this array contains the factors L and U from the LU +C factorization of A (A = P*L*U); the unit diagonal elements +C of L are not stored, L is lower bidiagonal, and P is +C stored in IWORK (see SLICOT Library routine MB02SD). +C Otherwise, this array is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C If JOBE = 'G', the leading N-by-N upper triangular part of +C this array must contain the upper triangular descriptor +C matrix E of the system. The elements of the strict lower +C triangular part of this array are not referenced. +C If JOBE = 'I', then E is assumed to be the identity +C matrix and is not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. +C LDE >= MAX(1,N), if JOBE = 'G'; +C LDE >= 1, if JOBE = 'I'. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, if M > 0, P > 0, OMEGA = 0, DICO = 'C', B <> 0, +C C <> 0, and INFO = 0 or N+1, the leading N-by-M part of +C this array contains the solution of the system A*X = B. +C Otherwise, this array is unchanged on exit. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the direct transmission matrix D. +C On exit, if (N = 0, or B = 0, or C = 0) and JOBD = 'D', +C or (OMEGA = 0, DICO = 'C', JOBD = 'D', and INFO = 0 or +C N+1), the contents of this array is destroyed. +C Otherwise, this array is unchanged on exit. +C This array is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK = N, if N > 0, M > 0, P > 0, B <> 0, and C <> 0; +C LIWORK = 0, otherwise. +C This array contains the pivot indices in the LU +C factorization of the matrix lambda*E - A; for 1 <= i <= N, +C row i of the matrix was interchanged with row IWORK(i). +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK, and DWORK(2), ..., DWORK(MIN(P,M)) contain the +C singular values of G(lambda), except for the first one, +C which is returned in the function value AB13DX. +C If (N = 0, or B = 0, or C = 0) and JOBD = 'Z', the last +C MIN(P,M)-1 zero singular values of G(lambda) are not +C stored in DWORK(2), ..., DWORK(MIN(P,M)). +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1, LDW1 + LDW2 ), +C LDW1 = P*M, if N > 0, B <> 0, C <> 0, OMEGA = 0, +C DICO = 'C', and JOBD = 'Z'; +C LDW1 = 0, otherwise; +C LDW2 = MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), 5*MIN(P,M)), +C if (N = 0, or B = 0, or C = 0) and JOBD = 'D', +C or (N > 0, B <> 0, C <> 0, OMEGA = 0, and +C DICO = 'C'); +C LDW2 = 0, if (N = 0, or B = 0, or C = 0) and JOBD = 'Z', +C or MIN(P,M) = 0; +C LDW2 = 6*MIN(P,M), otherwise. +C For good performance, LDWORK must generally be larger. +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) contains the optimal +C LCWORK. +C +C LCWORK INTEGER +C The dimension of the array CWORK. +C LCWORK >= 1, if N = 0, or B = 0, or C = 0, or (OMEGA = 0 +C and DICO = 'C') or MIN(P,M) = 0; +C LCWORK >= MAX(1, (N+M)*(N+P) + 2*MIN(P,M) + MAX(P,M)), +C otherwise. +C For good performance, LCWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, U(i,i) is exactly zero; the LU +C factorization of the matrix lambda*E - A has been +C completed, but the factor U is exactly singular, +C i.e., the matrix lambda*E - A is exactly singular; +C = N+1: the SVD algorithm for computing singular values +C did not converge. +C +C METHOD +C +C The routine implements standard linear algebra calculations, +C taking problem structure into account. LAPACK Library routines +C DGESVD and ZGESVD are used for finding the singular values. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 2005. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, system norm. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER DICO, JOBD, JOBE + INTEGER INFO, LCWORK, LDA, LDB, LDC, LDD, LDE, LDWORK, + $ M, N, P + DOUBLE PRECISION OMEGA +C .. +C .. Array Arguments .. + COMPLEX*16 CWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), E( LDE, * ) + INTEGER IWORK( * ) +C .. +C .. Local Scalars .. + LOGICAL DISCR, FULLE, NODYN, SPECL, WITHD + INTEGER I, ICB, ICC, ICD, ICWK, ID, IERR, IS, IWRK, J, + $ MAXWRK, MINCWR, MINPM, MINWRK + DOUBLE PRECISION BNORM, CNORM, LAMBDI, LAMBDR, UPD +C +C .. External Functions .. + DOUBLE PRECISION DLANGE + LOGICAL LSAME + EXTERNAL DLANGE, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, MB02RD, MB02RZ, MB02SD, MB02SZ, + $ XERBLA, ZGEMM, ZGESVD, ZLACP2 +C .. +C .. Intrinsic Functions .. + INTRINSIC COS, DCMPLX, INT, MAX, MIN, SIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + FULLE = LSAME( JOBE, 'G' ) + WITHD = LSAME( JOBD, 'D' ) +C + IF( .NOT. ( DISCR .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( FULLE .OR. LSAME( JOBE, 'I' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDE.LT.1 .OR. ( FULLE .AND. LDE.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -17 + ELSE + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + CNORM = DLANGE( '1-norm', P, N, C, LDC, DWORK ) + NODYN = N.EQ.0 .OR. MIN( BNORM, CNORM ).EQ.ZERO + SPECL = .NOT.NODYN .AND. OMEGA.EQ.ZERO .AND. .NOT.DISCR + MINPM = MIN( P, M ) +C +C Compute workspace. +C + IF( MINPM.EQ.0 ) THEN + MINWRK = 0 + ELSE IF( SPECL .OR. ( NODYN .AND. WITHD ) ) THEN + MINWRK = MINPM + MAX( 3*MINPM + MAX( P, M ), 5*MINPM ) + IF ( SPECL .AND. .NOT.WITHD ) + $ MINWRK = MINWRK + P*M + ELSE IF ( NODYN .AND. .NOT.WITHD ) THEN + MINWRK = 0 + ELSE + MINWRK = 6*MINPM + END IF + MINWRK = MAX( 1, MINWRK ) +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -20 + ELSE + IF ( NODYN .OR. ( OMEGA.EQ.ZERO .AND. .NOT.DISCR ) .OR. + $ MINPM.EQ.0 ) THEN + MINCWR = 1 + ELSE + MINCWR = MAX( 1, ( N + M )*( N + P ) + + $ 2*MINPM + MAX( P, M ) ) + END IF + IF( LCWORK.LT.MINCWR ) + $ INFO = -22 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13DX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MINPM.EQ.0 ) THEN + AB13DX = ZERO +C + DWORK( 1 ) = ONE + CWORK( 1 ) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + IS = 1 + IWRK = IS + MINPM +C + IF( NODYN ) THEN +C +C No dynamics: Determine the maximum singular value of G = D . +C + IF ( WITHD ) THEN +C +C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), +C 5*MIN(P,M)); +C prefer larger. +C + CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, + $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = N + 1 + RETURN + END IF + AB13DX = DWORK( IS ) + MAXWRK = INT( DWORK( IWRK ) ) + IWRK - 1 + ELSE + AB13DX = ZERO + MAXWRK = 1 + END IF +C + DWORK( 1 ) = MAXWRK + CWORK( 1 ) = ONE + RETURN + END IF +C +C Determine the maximum singular value of +C G(lambda) = C*inv(lambda*E - A)*B + D. +C The (generalized) Hessenberg form of the system is used. +C + IF ( SPECL ) THEN +C +C Special continuous-time case: +C Determine the maximum singular value of the real matrix G(0). +C Workspace: need MIN(P,M) + MAX(3*MIN(P,M) + MAX(P,M), +C 5*MIN(P,M)); +C prefer larger. +C + CALL MB02SD( N, A, LDA, IWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + DWORK( 1 ) = ONE + CWORK( 1 ) = ONE + RETURN + END IF + CALL MB02RD( 'No Transpose', N, M, A, LDA, IWORK, B, LDB, + $ IERR ) + IF ( WITHD ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, + $ C, LDC, B, LDB, ONE, D, LDD ) + CALL DGESVD( 'No Vectors', 'No Vectors', P, M, D, LDD, + $ DWORK( IS ), DWORK, P, DWORK, M, DWORK( IWRK ), + $ LDWORK-IWRK+1, IERR ) + ELSE +C +C Additional workspace: need P*M. +C + ID = IWRK + IWRK = ID + P*M + CALL DGEMM( 'No Transpose', 'No Transpose', P, M, N, -ONE, + $ C, LDC, B, LDB, ZERO, DWORK( ID ), P ) + CALL DGESVD( 'No Vectors', 'No Vectors', P, M, DWORK( ID ), + $ P, DWORK( IS ), DWORK, P, DWORK, M, + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + END IF + IF( IERR.GT.0 ) THEN + INFO = N + 1 + RETURN + END IF +C + AB13DX = DWORK( IS ) + DWORK( 1 ) = INT( DWORK( IWRK ) ) + IWRK - 1 + CWORK( 1 ) = ONE + RETURN + END IF +C +C General case: Determine the maximum singular value of G(lambda). +C Complex workspace: need N*N + N*M + P*N + P*M. +C + ICB = 1 + N*N + ICC = ICB + N*M + ICD = ICC + P*N + ICWK = ICD + P*M +C + IF ( WITHD ) THEN + UPD = ONE + ELSE + UPD = ZERO + END IF +C + IF ( DISCR ) THEN + LAMBDR = COS( OMEGA ) + LAMBDI = SIN( OMEGA ) +C +C Build lambda*E - A . +C + IF ( FULLE ) THEN +C + DO 20 J = 1, N +C + DO 10 I = 1, J + CWORK( I+(J-1)*N ) = + $ DCMPLX( LAMBDR*E( I, J ) - A( I, J ), + $ LAMBDI*E( I, J ) ) + 10 CONTINUE +C + IF( J.LT.N ) + $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) + 20 CONTINUE +C + ELSE +C + DO 40 J = 1, N +C + DO 30 I = 1, MIN( J+1, N ) + CWORK( I+(J-1)*N ) = -A( I, J ) + 30 CONTINUE +C + CWORK( J+(J-1)*N ) = DCMPLX( LAMBDR - A( J, J ), LAMBDI ) + 40 CONTINUE +C + END IF +C + ELSE +C +C Build j*omega*E - A. +C + IF ( FULLE ) THEN +C + DO 60 J = 1, N +C + DO 50 I = 1, J + CWORK( I+(J-1)*N ) = + $ DCMPLX( -A( I, J ), OMEGA*E( I, J ) ) + 50 CONTINUE +C + IF( J.LT.N ) + $ CWORK( J+1+(J-1)*N ) = DCMPLX( -A( J+1, J ), ZERO ) + 60 CONTINUE +C + ELSE +C + DO 80 J = 1, N +C + DO 70 I = 1, MIN( J+1, N ) + CWORK( I+(J-1)*N ) = -A( I, J ) + 70 CONTINUE +C + CWORK( J+(J-1)*N ) = DCMPLX( -A( J, J ), OMEGA ) + 80 CONTINUE +C + END IF +C + END IF +C +C Build G(lambda) . +C + CALL ZLACP2( 'Full', N, M, B, LDB, CWORK( ICB ), N ) + CALL ZLACP2( 'Full', P, N, C, LDC, CWORK( ICC ), P ) + IF ( WITHD ) + $ CALL ZLACP2( 'Full', P, M, D, LDD, CWORK( ICD ), P ) +C + CALL MB02SZ( N, CWORK, N, IWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + DWORK( 1 ) = ONE + CWORK( 1 ) = ICWK - 1 + RETURN + END IF + CALL MB02RZ( 'No Transpose', N, M, CWORK, N, IWORK, + $ CWORK( ICB ), N, IERR ) + CALL ZGEMM( 'No Transpose', 'No Transpose', P, M, N, CONE, + $ CWORK( ICC ), P, CWORK( ICB ), N, + $ DCMPLX( UPD, ZERO ), CWORK( ICD ), P ) +C +C Additional workspace, complex: need 2*MIN(P,M) + MAX(P,M); +C prefer larger; +C real: need 5*MIN(P,M). +C + CALL ZGESVD( 'No Vectors', 'No Vectors', P, M, CWORK( ICD ), P, + $ DWORK( IS ), CWORK, P, CWORK, M, CWORK( ICWK ), + $ LCWORK-ICWK+1, DWORK( IWRK ), IERR ) + IF( IERR.GT.0 ) THEN + INFO = N + 1 + RETURN + END IF + AB13DX = DWORK( IS ) +C + DWORK( 1 ) = 6*MINPM + CWORK( 1 ) = INT( CWORK( ICWK ) ) + ICWK - 1 +C + RETURN +C *** Last line of AB13DX *** + END diff --git a/mex/sources/libslicot/AB13ED.f b/mex/sources/libslicot/AB13ED.f new file mode 100644 index 000000000..32033b739 --- /dev/null +++ b/mex/sources/libslicot/AB13ED.f @@ -0,0 +1,347 @@ + SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate beta(A), the 2-norm distance from a real matrix A to +C the nearest complex matrix with an eigenvalue on the imaginary +C axis. The estimate is given as +C +C LOW <= beta(A) <= HIGH, +C +C where either +C +C (1 + TOL) * LOW >= HIGH, +C +C or +C +C LOW = 0 and HIGH = delta, +C +C and delta is a small number approximately equal to the square root +C of machine precision times the Frobenius norm (Euclidean norm) +C of A. If A is stable in the sense that all eigenvalues of A lie +C in the open left half complex plane, then beta(A) is the distance +C to the nearest unstable complex matrix, i.e., the complex +C stability radius. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C LOW (output) DOUBLE PRECISION +C A lower bound for beta(A). +C +C HIGH (output) DOUBLE PRECISION +C An upper bound for beta(A). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Specifies the accuracy with which LOW and HIGH approximate +C beta(A). If the user sets TOL to be less than SQRT(EPS), +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH), then the tolerance is taken to be +C SQRT(EPS). +C The recommended value is TOL = 9, which gives an estimate +C of beta(A) correct to within an order of magnitude. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, 3*N*(N+1) ). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm (LAPACK Library routine DHSEQR) +C fails to converge; this error is very rare. +C +C METHOD +C +C Let beta(A) be the 2-norm distance from a real matrix A to the +C nearest complex matrix with an eigenvalue on the imaginary axis. +C It is known that beta(A) = minimum of the smallest singular +C value of (A - jwI), where I is the identity matrix and j**2 = -1, +C and the minimum is taken over all real w. +C The algorithm computes a lower bound LOW and an upper bound HIGH +C for beta(A) by a bisection method in the following way. Given a +C non-negative real number sigma, the Hamiltonian matrix H(sigma) +C is constructed: +C +C | A -sigma*I | | A G | +C H(sigma) = | | := | | . +C | sigma*I -A' | | F -A' | +C +C It can be shown [1] that H(sigma) has an eigenvalue whose real +C part is zero if and only if sigma >= beta. Any lower and upper +C bounds on beta(A) can be improved by choosing a number between +C them and checking to see if H(sigma) has an eigenvalue with zero +C real part. This decision is made by computing the eigenvalues of +C H(sigma) using the square reduced algorithm of Van Loan [2]. +C +C REFERENCES +C +C [1] Byers, R. +C A bisection method for measuring the distance of a stable +C matrix to the unstable matrices. +C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. +C +C [2] Van Loan, C.F. +C A symplectic method for approximating all the eigenvalues of a +C Hamiltonian matrix. +C Linear Algebra and its Applications, Vol 61, 233-251, 1984. +C +C NUMERICAL ASPECTS +C +C Due to rounding errors the computed values of LOW and HIGH can be +C proven to satisfy +C +C LOW - p(n) * sqrt(e) * norm(A) <= beta(A) +C and +C beta(A) <= HIGH + p(n) * sqrt(e) * norm(A), +C +C where p(n) is a modest polynomial of degree 3, e is the machine +C precision and norm(A) is the Frobenius norm of A, see [1]. +C The recommended value for TOL is 9 which gives an estimate of +C beta(A) correct to within an order of magnitude. +C AB13ED requires approximately 38*N**3 flops for TOL = 9. +C +C CONTRIBUTOR +C +C R. Byers, the routines BISEC and BISEC0 (January, 1995). +C +C REVISIONS +C +C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. +C +C KEYWORDS +C +C Distances, eigenvalue, eigenvalue perturbation, norms, stability +C radius. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION HIGH, LOW, TOL + INTEGER INFO, LDA, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*) +C .. Local Scalars .. + INTEGER I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR, + $ JWORK, MINWRK, N2 + DOUBLE PRECISION ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2 + LOGICAL RNEG, SUFWRK +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, + $ DSYMV, MA02ED, MB04ZD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + MINWRK = 3*N*( N + 1 ) +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB13ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + LOW = ZERO + IF ( N.EQ.0 ) THEN + HIGH = ZERO + DWORK(1) = ONE + RETURN + END IF +C +C Indices for splitting the work array. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + N2 = N*N + IGF = 1 + IA2 = IGF + N2 + N + IAA = IA2 + N2 + IWK = IAA + N2 + IWR = IAA + IWI = IWR + N +C + SUFWRK = LDWORK-IWK.GE.N2 +C +C Computation of the tolerances and the treshold for termination of +C the bisection method. SEPS is the square root of the machine +C precision. +C + SFMN = DLAMCH( 'Safe minimum' ) + SEPS = SQRT( DLAMCH( 'Epsilon' ) ) + TAU = ONE + MAX( TOL, SEPS ) + ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + TOL1 = SEPS * ANRM + TOL2 = TOL1 * DBLE( 2*N ) +C +C Initialization of the bisection method. +C + HIGH = ANRM +C +C WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO + 10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN + SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) ) +C +C Set up H(sigma). +C Workspace: N*(N+1)+2*N*N. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) + DWORK(IGF) = SIGMA + DWORK(IGF+N) = -SIGMA + DUMMY(1) = ZERO + CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) +C + DO 20 I = IGF, IA2 - N - 2, N + 1 + CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) + 20 CONTINUE +C +C Computation of the eigenvalues by the square reduced algorithm. +C Workspace: N*(N+1)+2*N*N+2*N. +C + CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, + $ DUMMY2, 1, DWORK(IWK), INFO ) +C +C Form the matrix A*A + F*G. +C Workspace: need N*(N+1)+2*N*N+N; +C prefer N*(N+1)+3*N*N. +C + JWORK = IA2 + IF ( SUFWRK ) + $ JWORK = IWK +C + CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) + CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) +C + IF ( SUFWRK ) THEN +C +C Use BLAS 3 calculation. +C + CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, + $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) + ELSE +C +C Use BLAS 2 calculation. +C + DO 30 I = 1, N + CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, + $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) + CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) + 30 CONTINUE +C + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, + $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) +C +C Find the eigenvalues of A*A + F*G. +C Workspace: N*(N+1)+N*N+3*N. +C + JWORK = IWI + N + CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), + $ I ) + CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, + $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, + $ DWORK(JWORK), N, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C +C (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the +C squares of the eigenvalues of H(sigma). +C + I = 0 + RNEG = .FALSE. +C WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive +C .AND. I < N ) DO + 40 IF ( .NOT.RNEG .AND. I.LT.N ) THEN + TEMP = ABS( DWORK(IWI+I) ) + IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 + RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) ) + I = I + 1 + GO TO 40 +C END WHILE 40 + END IF + + IF ( RNEG ) THEN + HIGH = SIGMA + ELSE + LOW = SIGMA + END IF + GO TO 10 +C END WHILE 10 + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) ) +C +C *** Last line of AB13ED *** + END diff --git a/mex/sources/libslicot/AB13FD.f b/mex/sources/libslicot/AB13FD.f new file mode 100644 index 000000000..44628b470 --- /dev/null +++ b/mex/sources/libslicot/AB13FD.f @@ -0,0 +1,403 @@ + SUBROUTINE AB13FD( N, A, LDA, BETA, OMEGA, TOL, DWORK, LDWORK, + $ CWORK, LCWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute beta(A), the 2-norm distance from a real matrix A to +C the nearest complex matrix with an eigenvalue on the imaginary +C axis. If A is stable in the sense that all eigenvalues of A lie +C in the open left half complex plane, then beta(A) is the complex +C stability radius, i.e., the distance to the nearest unstable +C complex matrix. The value of beta(A) is the minimum of the +C smallest singular value of (A - jwI), taken over all real w. +C The value of w corresponding to the minimum is also computed. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C BETA (output) DOUBLE PRECISION +C The computed value of beta(A), which actually is an upper +C bound. +C +C OMEGA (output) DOUBLE PRECISION +C The value of w such that the smallest singular value of +C (A - jwI) equals beta(A). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Specifies the accuracy with which beta(A) is to be +C calculated. (See the Numerical Aspects section below.) +C If the user sets TOL to be less than EPS, where EPS is the +C machine precision (see LAPACK Library Routine DLAMCH), +C then the tolerance is taken to be EPS. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C If DWORK(1) is not needed, the first 2*N*N entries of +C DWORK may overlay CWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, 3*N*(N+2) ). +C For optimum performance LDWORK should be larger. +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0, CWORK(1) returns the optimal value +C of LCWORK. +C If CWORK(1) is not needed, the first N*N entries of +C CWORK may overlay DWORK. +C +C LCWORK INTEGER +C The length of the array CWORK. +C LCWORK >= MAX( 1, N*(N+3) ). +C For optimum performance LCWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the routine fails to compute beta(A) within the +C specified tolerance. Nevertheless, the returned +C value is an upper bound on beta(A); +C = 2: either the QR or SVD algorithm (LAPACK Library +C routines DHSEQR, DGESVD or ZGESVD) fails to +C converge; this error is very rare. +C +C METHOD +C +C AB13FD combines the methods of [1] and [2] into a provably +C reliable, quadratically convergent algorithm. It uses the simple +C bisection strategy of [1] to find an interval which contains +C beta(A), and then switches to the modified bisection strategy of +C [2] which converges quadratically to a minimizer. Note that the +C efficiency of the strategy degrades if there are several local +C minima that are near or equal the global minimum. +C +C REFERENCES +C +C [1] Byers, R. +C A bisection method for measuring the distance of a stable +C matrix to the unstable matrices. +C SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988. +C +C [2] Boyd, S. and Balakrishnan, K. +C A regularity result for the singular values of a transfer +C matrix and a quadratically convergent algorithm for computing +C its L-infinity norm. +C Systems and Control Letters, Vol. 15, pp. 1-7, 1990. +C +C NUMERICAL ASPECTS +C +C In the presence of rounding errors, the computed function value +C BETA satisfies +C +C beta(A) <= BETA + epsilon, +C +C BETA/(1+TOL) - delta <= MAX(beta(A), SQRT(2*N*EPS)*norm(A)), +C +C where norm(A) is the Frobenius norm of A, +C +C epsilon = p(N) * EPS * norm(A), +C and +C delta = p(N) * SQRT(EPS) * norm(A), +C +C and p(N) is a low degree polynomial. It is recommended to choose +C TOL greater than SQRT(EPS). Although rounding errors can cause +C AB13FD to fail for smaller values of TOL, nevertheless, it usually +C succeeds. Regardless of success or failure, the first inequality +C holds. +C +C CONTRIBUTORS +C +C R. Byers, the routines QSEC and QSEC0 (January, 1995). +C +C REVISIONS +C +C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2002, +C Jan. 2003. +C +C KEYWORDS +C +C complex stability radius, distances, eigenvalue, eigenvalue +C perturbation, norms. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 50 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LCWORK, LDA, LDWORK, N + DOUBLE PRECISION BETA, OMEGA, TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*) + COMPLEX*16 CWORK(*) +C .. Local Scalars .. + INTEGER I, IA2, IAA, IGF, IHI, ILO, ITNUM, IWI, IWK, + $ IWR, JWORK, KOM, LBEST, MINWRK, N2 + DOUBLE PRECISION EPS, LOW, OM, OM1, OM2, SFMN, SIGMA, SV, TAU, + $ TEMP, TOL1 + LOGICAL SUFWRK +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1), DUMMY2(1,1) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, MB03NY + EXTERNAL DLAMCH, DLANGE, MB03NY +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM, + $ DSYMV, MA02ED, MB04ZD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, SQRT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + MINWRK = 3*N*( N + 2 ) +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN + INFO = -8 + ELSE IF( LCWORK.LT.MAX( 1, N*( N + 3 ) ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB13FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + OMEGA = ZERO + IF ( N.EQ.0 ) THEN + BETA = ZERO + DWORK(1) = ONE + CWORK(1) = CONE + RETURN + END IF +C +C Indices for splitting the work array. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance.) +C + N2 = N*N + IGF = 1 + IA2 = IGF + N2 + N + IAA = IA2 + N2 + IWK = IAA + N2 + IWR = IAA + IWI = IWR + N +C + SUFWRK = LDWORK-IWK.GE.N2 +C +C Computation of the tolerances. EPS is the machine precision. +C + SFMN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + TOL1 = SQRT( EPS * DBLE( 2*N ) ) * + $ DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + TAU = ONE + MAX( TOL, EPS ) +C +C Initialization, upper bound at known critical point. +C Workspace: need N*(N+1)+5*N; prefer larger. +C + KOM = 2 + LOW = ZERO + CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) + BETA = MB03NY( N, OMEGA, DWORK(IGF), N, DWORK(IGF+N2), + $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + LBEST = MAX( MINWRK, INT( DWORK(IA2) ) - IA2 + 1, 4*N2 + N ) +C + ITNUM = 1 +C WHILE ( ITNUM <= MAXIT and BETA > TAU*MAX( TOL1, LOW ) ) DO + 10 IF ( ( ITNUM.LE.MAXIT ) .AND. + $ ( BETA.GT.TAU*MAX( TOL1, LOW ) ) ) THEN + IF ( KOM.EQ.2 ) THEN + SIGMA = BETA/TAU + ELSE + SIGMA = SQRT( BETA ) * SQRT( MAX( TOL1, LOW ) ) + END IF +C +C Set up H(sigma). +C Workspace: N*(N+1)+2*N*N. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N ) + DWORK(IGF) = SIGMA + DWORK(IGF+N) = -SIGMA + DUMMY(1) = ZERO + CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 ) +C + DO 20 I = IGF, IA2 - N - 2, N + 1 + CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 ) + 20 CONTINUE +C +C Computation of the eigenvalues by the square reduced algorithm. +C Workspace: N*(N+1)+2*N*N+2*N. +C + CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N, + $ DUMMY2, 1, DWORK(IWK), INFO ) +C +C Form the matrix A*A + F*G. +C Workspace: need N*(N+1)+2*N*N+N; +C prefer N*(N+1)+3*N*N. +C + JWORK = IA2 + IF ( SUFWRK ) + $ JWORK = IWK +C + CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N ) + CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) +C + IF ( SUFWRK ) THEN +C +C Use BLAS 3 calculation. +C + CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N, + $ DWORK(JWORK), N, ZERO, DWORK(IA2), N ) + ELSE +C +C Use BLAS 2 calculation. +C + DO 30 I = 1, N + CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N, + $ DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 ) + CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 ) + 30 CONTINUE +C + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, + $ DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N ) +C +C Find the eigenvalues of A*A + F*G. +C Workspace: N*(N+1)+N*N+3*N. +C + JWORK = IWI + N + CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK), + $ I ) + CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, + $ DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1, + $ DWORK(JWORK), N, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Count negative real axis squared eigenvalues. If there are two, +C then the valley is isolated, and next approximate minimizer is +C mean of the square roots. +C + KOM = 0 + DO 40 I = 0, N - 1 + TEMP = ABS( DWORK(IWI+I) ) + IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1 + IF ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL1 ) ) THEN + KOM = KOM + 1 + OM = SQRT( -DWORK(IWR+I) ) + IF ( KOM.EQ.1 ) OM1 = OM + IF ( KOM.EQ.2 ) OM2 = OM + END IF + 40 CONTINUE +C + IF ( KOM.EQ.0 ) THEN + LOW = SIGMA + ELSE +C +C In exact arithmetic KOM = 1 is impossible, but if tau is +C close enough to one, MB04ZD may miss the initial near zero +C eigenvalue. +C Workspace, real: need 3*N*(N+2); prefer larger; +C complex: need N*(N+3); prefer larger. +C + IF ( KOM.EQ.2 ) THEN + OM = OM1 + ( OM2 - OM1 ) / TWO + ELSE IF ( KOM.EQ.1 .AND. ITNUM.EQ.1 ) THEN + OM = OM1 / TWO + KOM = 2 + END IF +C + CALL DLACPY( 'All', N, N, A, LDA, DWORK(IGF), N ) + SV = MB03NY( N, OM, DWORK(IGF), N, DWORK(IGF+N2), + $ DWORK(IA2), LDWORK-IA2, CWORK, LCWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + IF ( BETA.GT.SV ) THEN + BETA = SV + OMEGA = OM + ELSE + INFO = 1 + RETURN + END IF + END IF + ITNUM = ITNUM + 1 + GO TO 10 +C END WHILE 10 + END IF +C + IF ( BETA .GT. TAU*MAX( TOL1, LOW ) ) THEN +C +C Failed to meet bounds within MAXIT iterations. +C + INFO = 1 + RETURN + END IF +C +C Set optimal real workspace dimension (complex workspace is already +C set by MB03NY). +C + DWORK(1) = LBEST +C + RETURN +C *** Last line of AB13FD *** + END diff --git a/mex/sources/libslicot/AB13MD.f b/mex/sources/libslicot/AB13MD.f new file mode 100644 index 000000000..e0e0d4724 --- /dev/null +++ b/mex/sources/libslicot/AB13MD.f @@ -0,0 +1,1782 @@ + SUBROUTINE AB13MD( FACT, N, Z, LDZ, M, NBLOCK, ITYPE, X, BOUND, D, + $ G, IWORK, DWORK, LDWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an upper bound on the structured singular value for a +C given square complex matrix and a given block structure of the +C uncertainty. +C +C ARGUMENTS +C +C Mode Parameters +C +C FACT CHARACTER*1 +C Specifies whether or not an information from the +C previous call is supplied in the vector X. +C = 'F': On entry, X contains information from the +C previous call. +C = 'N': On entry, X does not contain an information from +C the previous call. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix Z. N >= 0. +C +C Z (input) COMPLEX*16 array, dimension (LDZ,N) +C The leading N-by-N part of this array must contain the +C complex matrix Z for which the upper bound on the +C structured singular value is to be computed. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= max(1,N). +C +C M (input) INTEGER +C The number of diagonal blocks in the block structure of +C the uncertainty. M >= 1. +C +C NBLOCK (input) INTEGER array, dimension (M) +C The vector of length M containing the block structure +C of the uncertainty. NBLOCK(I), I = 1:M, is the size of +C each block. +C +C ITYPE (input) INTEGER array, dimension (M) +C The vector of length M indicating the type of each block. +C For I = 1:M, +C ITYPE(I) = 1 indicates that the corresponding block is a +C real block, and +C ITYPE(I) = 2 indicates that the corresponding block is a +C complex block. +C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. +C +C X (input/output) DOUBLE PRECISION array, dimension +C ( M + MR - 1 ), where MR is the number of the real blocks. +C On entry, if FACT = 'F' and NBLOCK(1) < N, this array +C must contain information from the previous call to AB13MD. +C If NBLOCK(1) = N, this array is not used. +C On exit, if NBLOCK(1) < N, this array contains information +C that can be used in the next call to AB13MD for a matrix +C close to Z. +C +C BOUND (output) DOUBLE PRECISION +C The upper bound on the structured singular value. +C +C D, G (output) DOUBLE PRECISION arrays, dimension (N) +C The vectors of length N containing the diagonal entries +C of the diagonal N-by-N matrices D and G, respectively, +C such that the matrix +C Z'*D^2*Z + sqrt(-1)*(G*Z-Z'*G) - BOUND^2*D^2 +C is negative semidefinite. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(4*M-2,N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11. +C For best performance +C LDWORK >= 2*N*N*M - N*N + 9*M*M + N*M + 6*N + 33*M - 11 + +C MAX( 5*N,2*N*NB ) +C where NB is the optimal blocksize returned by ILAENV. +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) contains the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The dimension of the array ZWORK. +C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 6*N - 3. +C For best performance +C LZWORK >= 6*N*N*M + 12*N*N + 6*M + 3*N - 3 + +C MAX( 3*N,N*NB ) +C where NB is the optimal blocksize returned by ILAENV. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the block sizes must be positive integers; +C = 2: the sum of block sizes must be equal to N; +C = 3: the size of a real block must be equal to 1; +C = 4: the block type must be either 1 or 2; +C = 5: errors in solving linear equations or in matrix +C inversion; +C = 6: errors in computing eigenvalues or singular values. +C +C METHOD +C +C The routine computes the upper bound proposed in [1]. +C +C REFERENCES +C +C [1] Fan, M.K.H., Tits, A.L., and Doyle, J.C. +C Robustness in the presence of mixed parametric uncertainty +C and unmodeled dynamics. +C IEEE Trans. Automatic Control, vol. AC-36, 1991, pp. 25-38. +C +C NUMERICAL ASPECTS +C +C The accuracy and speed of computation depend on the value of +C the internal threshold TOL. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, F. Delebecque, D.W. Gu, M.M. Konstantinov and +C S. Steer with the assistance of V. Sima, September 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Universiteit Leuven, February 2001. +C +C KEYWORDS +C +C H-infinity optimal control, Robust control, Structured singular +C value. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 CZERO, CONE, CIMAG + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ), + $ CIMAG = ( 0.0D+0, 1.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, FIVE, EIGHT, TEN, FORTY, + $ FIFTY + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, FIVE = 5.0D+0, EIGHT = 8.0D+0, + $ TEN = 1.0D+1, FORTY = 4.0D+1, FIFTY = 5.0D+1 + $ ) + DOUBLE PRECISION ALPHA, BETA, THETA + PARAMETER ( ALPHA = 100.0D+0, BETA = 1.0D-2, + $ THETA = 1.0D-2 ) + DOUBLE PRECISION C1, C2, C3, C4, C5, C6, C7, C8, C9 + PARAMETER ( C1 = 1.0D-3, C2 = 1.0D-2, C3 = 0.25D+0, + $ C4 = 0.9D+0, C5 = 1.5D+0, C6 = 1.0D+1, + $ C7 = 1.0D+2, C8 = 1.0D+3, C9 = 1.0D+4 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT + INTEGER INFO, LDWORK, LDZ, LZWORK, M, N + DOUBLE PRECISION BOUND +C .. +C .. Array Arguments .. + INTEGER ITYPE( * ), IWORK( * ), NBLOCK( * ) + COMPLEX*16 Z( LDZ, * ), ZWORK( * ) + DOUBLE PRECISION D( * ), DWORK( * ), G( * ), X( * ) +C .. +C .. Local Scalars .. + INTEGER I, INFO2, ISUM, ITER, IW2, IW3, IW4, IW5, IW6, + $ IW7, IW8, IW9, IW10, IW11, IW12, IW13, IW14, + $ IW15, IW16, IW17, IW18, IW19, IW20, IW21, IW22, + $ IW23, IW24, IW25, IW26, IW27, IW28, IW29, IW30, + $ IW31, IW32, IW33, IWRK, IZ2, IZ3, IZ4, IZ5, + $ IZ6, IZ7, IZ8, IZ9, IZ10, IZ11, IZ12, IZ13, + $ IZ14, IZ15, IZ16, IZ17, IZ18, IZ19, IZ20, IZ21, + $ IZ22, IZ23, IZ24, IZWRK, J, K, L, LWA, LWAMAX, + $ LZA, LZAMAX, MINWRK, MINZRK, MR, MT, NSUM, SDIM + COMPLEX*16 DETF, TEMPIJ, TEMPJI + DOUBLE PRECISION C, COLSUM, DELTA, DLAMBD, E, EMAX, EMIN, EPS, + $ HN, HNORM, HNORM1, PHI, PP, PROD, RAT, RCOND, + $ REGPAR, ROWSUM, SCALE, SNORM, STSIZE, SVLAM, + $ T1, T2, T3, TAU, TEMP, TOL, TOL2, TOL3, TOL4, + $ TOL5, YNORM1, YNORM2, ZNORM, ZNORM2 + LOGICAL GTEST, POS, XFACT +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions + DOUBLE PRECISION DDOT, DLAMCH, DLANGE, ZLANGE + LOGICAL LSAME, SELECT + EXTERNAL DDOT, DLAMCH, DLANGE, LSAME, SELECT, ZLANGE +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLACPY, DLASET, DSCAL, DSYCON, + $ DSYSV, DSYTRF, DSYTRS, XERBLA, ZCOPY, ZGEES, + $ ZGEMM, ZGEMV, ZGESVD, ZGETRF, ZGETRI, ZLACPY, + $ ZLASCL +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, DCONJG, DFLOAT, DREAL, INT, LOG, + $ MAX, SQRT +C .. +C .. Executable Statements .. +C +C Compute workspace. +C + MINWRK = 2*N*N*M - N*N + 9*M*M + N*M + 11*N + 33*M - 11 + MINZRK = 6*N*N*M + 12*N*N + 6*M + 6*N - 3 +C +C Decode and Test input parameters. +C + INFO = 0 + XFACT = LSAME( FACT, 'F' ) + IF( .NOT.XFACT .AND. .NOT.LSAME( FACT, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( M.LT.1 ) THEN + INFO = -5 + ELSE IF( LDWORK.LT.MINWRK ) THEN + INFO = -14 + ELSE IF( LZWORK.LT.MINZRK ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AB13MD', -INFO ) + RETURN + END IF +C + NSUM = 0 + ISUM = 0 + MR = 0 + DO 10 I = 1, M + IF( NBLOCK( I ).LT.1 ) THEN + INFO = 1 + RETURN + END IF + IF( ITYPE( I ).EQ.1 .AND. NBLOCK( I ).GT.1 ) THEN + INFO = 3 + RETURN + END IF + NSUM = NSUM + NBLOCK( I ) + IF( ITYPE( I ).EQ.1 ) MR = MR + 1 + IF( ITYPE( I ).EQ.1 .OR. ITYPE( I ).EQ.2 ) ISUM = ISUM + 1 + 10 CONTINUE + IF( NSUM.NE.N ) THEN + INFO = 2 + RETURN + END IF + IF( ISUM.NE.M ) THEN + INFO = 4 + RETURN + END IF + MT = M + MR - 1 +C + LWAMAX = 0 + LZAMAX = 0 +C +C Set D = In, G = 0. +C + CALL DLASET( 'Full', N, 1, ONE, ONE, D, N ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, G, N ) +C +C Quick return if possible. +C + ZNORM = ZLANGE( 'F', N, N, Z, LDZ, DWORK ) + IF( ZNORM.EQ.ZERO ) THEN + BOUND = ZERO + DWORK( 1 ) = ONE + ZWORK( 1 ) = CONE + RETURN + END IF +C +C Copy Z into ZWORK. +C + CALL ZLACPY( 'Full', N, N, Z, LDZ, ZWORK, N ) +C +C Exact bound for the case NBLOCK( 1 ) = N. +C + IF( NBLOCK( 1 ).EQ.N ) THEN + IF( ITYPE( 1 ).EQ.1 ) THEN +C +C 1-by-1 real block. +C + BOUND = ZERO + DWORK( 1 ) = ONE + ZWORK( 1 ) = CONE + ELSE +C +C N-by-N complex block. +C + CALL ZGESVD( 'N', 'N', N, N, ZWORK, N, DWORK, ZWORK, 1, + $ ZWORK, 1, ZWORK( N*N+1 ), LZWORK, + $ DWORK( N+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + BOUND = DWORK( 1 ) + LZA = N*N + INT( ZWORK( N*N+1 ) ) + DWORK( 1 ) = 5*N + ZWORK( 1 ) = DCMPLX( LZA ) + END IF + RETURN + END IF +C +C Get machine precision. +C + EPS = DLAMCH( 'P' ) +C +C Set tolerances. +C + TOL = C7*SQRT( EPS ) + TOL2 = C9*EPS + TOL3 = C6*EPS + TOL4 = C1 + TOL5 = C1 + REGPAR = C8*EPS +C +C Real workspace usage. +C + IW2 = M*M + IW3 = IW2 + M + IW4 = IW3 + N + IW5 = IW4 + M + IW6 = IW5 + M + IW7 = IW6 + N + IW8 = IW7 + N + IW9 = IW8 + N*( M - 1 ) + IW10 = IW9 + N*N*MT + IW11 = IW10 + MT + IW12 = IW11 + MT*MT + IW13 = IW12 + N + IW14 = IW13 + MT + 1 + IW15 = IW14 + MT + 1 + IW16 = IW15 + MT + 1 + IW17 = IW16 + MT + 1 + IW18 = IW17 + MT + 1 + IW19 = IW18 + MT + IW20 = IW19 + MT + IW21 = IW20 + MT + IW22 = IW21 + N + IW23 = IW22 + M - 1 + IW24 = IW23 + MR + IW25 = IW24 + N + IW26 = IW25 + 2*MT + IW27 = IW26 + MT + IW28 = IW27 + MT + IW29 = IW28 + M - 1 + IW30 = IW29 + MR + IW31 = IW30 + N + 2*MT + IW32 = IW31 + MT*MT + IW33 = IW32 + MT + IWRK = IW33 + MT + 1 +C +C Double complex workspace usage. +C + IZ2 = N*N + IZ3 = IZ2 + N*N + IZ4 = IZ3 + N*N + IZ5 = IZ4 + N*N + IZ6 = IZ5 + N*N + IZ7 = IZ6 + N*N*MT + IZ8 = IZ7 + N*N + IZ9 = IZ8 + N*N + IZ10 = IZ9 + N*N + IZ11 = IZ10 + MT + IZ12 = IZ11 + N*N + IZ13 = IZ12 + N + IZ14 = IZ13 + N*N + IZ15 = IZ14 + N + IZ16 = IZ15 + N*N + IZ17 = IZ16 + N + IZ18 = IZ17 + N*N + IZ19 = IZ18 + N*N*MT + IZ20 = IZ19 + MT + IZ21 = IZ20 + N*N*MT + IZ22 = IZ21 + N*N + IZ23 = IZ22 + N*N + IZ24 = IZ23 + N*N + IZWRK = IZ24 + MT +C +C Compute the cumulative sums of blocks dimensions. +C + IWORK( 1 ) = 0 + DO 20 I = 2, M+1 + IWORK( I ) = IWORK( I - 1 ) + NBLOCK( I - 1 ) + 20 CONTINUE +C +C Find Osborne scaling if initial scaling is not given. +C + IF( .NOT.XFACT ) THEN + CALL DLASET( 'Full', M, M, ZERO, ZERO, DWORK, M ) + CALL DLASET( 'Full', M, 1, ONE, ONE, DWORK( IW2+1 ), M ) + ZNORM = ZLANGE( 'F', N, N, ZWORK, N, DWORK ) + DO 40 J = 1, M + DO 30 I = 1, M + IF( I.NE.J ) THEN + CALL ZLACPY( 'Full', IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), + $ Z( IWORK( I )+1, IWORK( J )+1 ), LDZ, + $ ZWORK( IZ2+1 ), N ) + CALL ZGESVD( 'N', 'N', IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), ZWORK( IZ2+1 ), + $ N, DWORK( IW3+1 ), ZWORK, 1, ZWORK, 1, + $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + ZNORM2 = DWORK( IW3+1 ) + DWORK( I+(J-1)*M ) = ZNORM2 + ZNORM*TOL2 + END IF + 30 CONTINUE + 40 CONTINUE + CALL DLASET( 'Full', M, 1, ZERO, ZERO, DWORK( IW4+1 ), M ) + 50 DO 60 I = 1, M + DWORK( IW5+I ) = DWORK( IW4+I ) - ONE + 60 CONTINUE + HNORM = DLANGE( 'F', M, 1, DWORK( IW5+1 ), M, DWORK ) + IF( HNORM.LE.TOL2 ) GO TO 120 + DO 110 K = 1, M + COLSUM = ZERO + DO 70 I = 1, M + COLSUM = COLSUM + DWORK( I+(K-1)*M ) + 70 CONTINUE + ROWSUM = ZERO + DO 80 J = 1, M + ROWSUM = ROWSUM + DWORK( K+(J-1)*M ) + 80 CONTINUE + RAT = SQRT( COLSUM / ROWSUM ) + DWORK( IW4+K ) = RAT + DO 90 I = 1, M + DWORK( I+(K-1)*M ) = DWORK( I+(K-1)*M ) / RAT + 90 CONTINUE + DO 100 J = 1, M + DWORK( K+(J-1)*M ) = DWORK( K+(J-1)*M )*RAT + 100 CONTINUE + DWORK( IW2+K ) = DWORK( IW2+K )*RAT + 110 CONTINUE + GO TO 50 + 120 SCALE = ONE / DWORK( IW2+1 ) + CALL DSCAL( M, SCALE, DWORK( IW2+1 ), 1 ) + ELSE + DWORK( IW2+1 ) = ONE + DO 130 I = 2, M + DWORK( IW2+I ) = SQRT( X( I-1 ) ) + 130 CONTINUE + END IF + DO 150 J = 1, M + DO 140 I = 1, M + IF( I.NE.J ) THEN + CALL ZLASCL( 'G', M, M, DWORK( IW2+J ), DWORK( IW2+I ), + $ IWORK( I+1 )-IWORK( I ), + $ IWORK( J+1 )-IWORK( J ), + $ ZWORK( IWORK( I )+1+IWORK( J )*N ), N, + $ INFO2 ) + END IF + 140 CONTINUE + 150 CONTINUE +C +C Scale Z by its 2-norm. +C + CALL ZLACPY( 'Full', N, N, ZWORK, N, ZWORK( IZ2+1 ), N ) + CALL ZGESVD( 'N', 'N', N, N, ZWORK( IZ2+1 ), N, DWORK( IW3+1 ), + $ ZWORK, 1, ZWORK, 1, ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + ZNORM = DWORK( IW3+1 ) + CALL ZLASCL( 'G', M, M, ZNORM, ONE, N, N, ZWORK, N, INFO2 ) +C +C Set BB. +C + CALL DLASET( 'Full', N*N, MT, ZERO, ZERO, DWORK( IW9+1 ), N*N ) +C +C Set P. +C + DO 160 I = 1, NBLOCK( 1 ) + DWORK( IW6+I ) = ONE + 160 CONTINUE + DO 170 I = NBLOCK( 1 )+1, N + DWORK( IW6+I ) = ZERO + 170 CONTINUE +C +C Compute P*Z. +C + DO 190 J = 1, N + DO 180 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 180 CONTINUE + 190 CONTINUE +C +C Compute Z'*P*Z. +C + CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), N, + $ CZERO, ZWORK( IZ4+1 ), N ) +C +C Copy Z'*P*Z into A0. +C + CALL ZLACPY( 'Full', N, N, ZWORK( IZ4+1 ), N, ZWORK( IZ5+1 ), N ) +C +C Copy diag(P) into B0d. +C + CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW7+1 ), 1 ) +C + DO 270 K = 2, M +C +C Set P. +C + DO 200 I = 1, IWORK( K ) + DWORK( IW6+I ) = ZERO + 200 CONTINUE + DO 210 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) + DWORK( IW6+I ) = ONE + 210 CONTINUE + IF( K.LT.M ) THEN + DO 220 I = IWORK( K+1 )+1, N + DWORK( IW6+I ) = ZERO + 220 CONTINUE + END IF +C +C Compute P*Z. +C + DO 240 J = 1, N + DO 230 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 230 CONTINUE + 240 CONTINUE +C +C Compute t = Z'*P*Z. +C + CALL ZGEMM( 'C', 'N', N, N, N, CONE, ZWORK, N, ZWORK( IZ3+1 ), + $ N, CZERO, ZWORK( IZ4+1 ), N ) +C +C Copy t(:) into the (k-1)-th column of AA. +C + CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, ZWORK( IZ6+1+(K-2)*N*N ), + $ 1 ) +C +C Copy diag(P) into the (k-1)-th column of BBd. +C + CALL DCOPY( N, DWORK( IW6+1 ), 1, DWORK( IW8+1+(K-2)*N ), 1 ) +C +C Copy P(:) into the (k-1)-th column of BB. +C + DO 260 I = 1, N + DWORK( IW9+I+(I-1)*N+(K-2)*N*N ) = DWORK( IW6+I ) + 260 CONTINUE + 270 CONTINUE +C + L = 0 +C + DO 350 K = 1, M + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 +C +C Set P. +C + DO 280 I = 1, IWORK( K ) + DWORK( IW6+I ) = ZERO + 280 CONTINUE + DO 290 I = IWORK( K )+1, IWORK( K )+NBLOCK( K ) + DWORK( IW6+I ) = ONE + 290 CONTINUE + IF( K.LT.M ) THEN + DO 300 I = IWORK( K+1 )+1, N + DWORK( IW6+I ) = ZERO + 300 CONTINUE + END IF +C +C Compute P*Z. +C + DO 320 J = 1, N + DO 310 I = 1, N + ZWORK( IZ3+I+(J-1)*N ) = DCMPLX( DWORK( IW6+I ) )* + $ ZWORK( I+(J-1)*N ) + 310 CONTINUE + 320 CONTINUE +C +C Compute t = sqrt(-1)*( P*Z - Z'*P ). +C + DO 340 J = 1, N + DO 330 I = 1, J + TEMPIJ = ZWORK( IZ3+I+(J-1)*N ) + TEMPJI = ZWORK( IZ3+J+(I-1)*N ) + ZWORK( IZ4+I+(J-1)*N ) = CIMAG*( TEMPIJ - + $ DCONJG( TEMPJI ) ) + ZWORK( IZ4+J+(I-1)*N ) = CIMAG*( TEMPJI - + $ DCONJG( TEMPIJ ) ) + 330 CONTINUE + 340 CONTINUE +C +C Copy t(:) into the (m-1+l)-th column of AA. +C + CALL ZCOPY( N*N, ZWORK( IZ4+1 ), 1, + $ ZWORK( IZ6+1+(M-2+L)*N*N ), 1 ) + END IF + 350 CONTINUE +C +C Set initial X. +C + DO 360 I = 1, M - 1 + X( I ) = ONE + 360 CONTINUE + IF( MR.GT.0 ) THEN + IF( .NOT.XFACT ) THEN + DO 370 I = 1, MR + X( M-1+I ) = ZERO + 370 CONTINUE + ELSE + L = 0 + DO 380 K = 1, M + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 + X( M-1+L ) = X( M-1+L ) / DWORK( IW2+K )**2 + END IF + 380 CONTINUE + END IF + END IF +C +C Set constants. +C + SVLAM = ONE / EPS + C = ONE +C +C Set H. +C + CALL DLASET( 'Full', MT, MT, ZERO, ONE, DWORK( IW11+1 ), MT ) +C + ITER = -1 +C +C Main iteration loop. +C + 390 ITER = ITER + 1 +C +C Compute A(:) = A0 + AA*x. +C + DO 400 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 400 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( Binv ). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW12+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, + $ DWORK( IW12+1 ), 1 ) + DO 410 I = 1, N + DWORK( IW12+I ) = ONE / DWORK( IW12+I ) + 410 CONTINUE +C +C Compute Binv*A. +C + DO 430 J = 1, N + DO 420 I = 1, N + ZWORK( IZ11+I+(J-1)*N ) = DCMPLX( DWORK( IW12+I ) )* + $ ZWORK( IZ7+I+(J-1)*N ) + 420 CONTINUE + 430 CONTINUE +C +C Compute eig( Binv*A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ11+1 ), N, SDIM, + $ ZWORK( IZ12+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + E = DREAL( ZWORK( IZ12+1 ) ) + IF( N.GT.1 ) THEN + DO 440 I = 2, N + IF( DREAL( ZWORK( IZ12+I ) ).GT.E ) + $ E = DREAL( ZWORK( IZ12+I ) ) + 440 CONTINUE + END IF +C +C Set tau. +C + IF( MR.GT.0 ) THEN + SNORM = ABS( X( M ) ) + IF( MR.GT.1 ) THEN + DO 450 I = M+1, MT + IF( ABS( X( I ) ).GT.SNORM ) SNORM = ABS( X( I ) ) + 450 CONTINUE + END IF + IF( SNORM.GT.FORTY ) THEN + TAU = C7 + ELSE IF( SNORM.GT.EIGHT ) THEN + TAU = FIFTY + ELSE IF( SNORM.GT.FOUR ) THEN + TAU = TEN + ELSE IF( SNORM.GT.ONE ) THEN + TAU = FIVE + ELSE + TAU = TWO + END IF + END IF + IF( ITER.EQ.0 ) THEN + DLAMBD = E + C1 + ELSE + DWORK( IW13+1 ) = E + CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) + DLAMBD = ( ONE - THETA )*DWORK( IW13+1 ) + + $ THETA*DWORK( IW14+1 ) + CALL DCOPY( MT, DWORK( IW13+2 ), 1, DWORK( IW18+1 ), 1 ) + CALL DCOPY( MT, DWORK( IW14+2 ), 1, DWORK( IW19+1 ), 1 ) + L = 0 + 460 DO 470 I = 1, MT + X( I ) = ( ONE - THETA / TWO**L )*DWORK( IW18+I ) + + $ ( THETA / TWO**L )*DWORK( IW19+I ) + 470 CONTINUE +C +C Compute At(:) = A0 + AA*x. +C + DO 480 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 480 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ9+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ9+1 ), 1 ) +C +C Compute diag(Bt). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW21+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, X, 1, ONE, + $ DWORK( IW21+1 ), 1 ) +C +C Compute W. +C + DO 500 J = 1, N + DO 490 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ13+I+(I-1)*N ) = DCMPLX( THETA*BETA* + $ ( DWORK( IW14+1 ) - DWORK( IW13+1 ) ) /TWO - + $ DLAMBD*DWORK( IW21+I ) ) + + $ ZWORK( IZ9+I+(I-1)*N ) + ELSE + ZWORK( IZ13+I+(J-1)*N ) = ZWORK( IZ9+I+(J-1)*N ) + END IF + 490 CONTINUE + 500 CONTINUE +C +C Compute eig( W ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ13+1 ), N, SDIM, + $ ZWORK( IZ14+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMAX = DREAL( ZWORK( IZ14+1 ) ) + IF( N.GT.1 ) THEN + DO 510 I = 2, N + IF( DREAL( ZWORK( IZ14+I ) ).GT.EMAX ) + $ EMAX = DREAL( ZWORK( IZ14+I ) ) + 510 CONTINUE + END IF + IF( EMAX.LE.ZERO ) THEN + GO TO 515 + ELSE + L = L + 1 + GO TO 460 + END IF + END IF +C +C Set y. +C + 515 DWORK( IW13+1 ) = DLAMBD + CALL DCOPY( MT, X, 1, DWORK( IW13+2 ), 1 ) +C + IF( ( SVLAM - DLAMBD ).LT.TOL ) THEN + BOUND = SQRT( MAX( E, ZERO ) )*ZNORM + DO 520 I = 1, M - 1 + X( I ) = X( I )*DWORK( IW2+I+1 )**2 + 520 CONTINUE +C +C Compute sqrt( x ). +C + DO 530 I = 1, M-1 + DWORK( IW20+I ) = SQRT( X( I ) ) + 530 CONTINUE +C +C Compute diag( D ). +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, D, 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW20+1 ), 1, ONE, D, 1 ) +C +C Compute diag( G ). +C + J = 0 + L = 0 + DO 540 K = 1, M + J = J + NBLOCK( K ) + IF( ITYPE( K ).EQ.1 ) THEN + L = L + 1 + X( M-1+L ) = X( M-1+L )*DWORK( IW2+K )**2 + G( J ) = X( M-1+L ) + END IF + 540 CONTINUE + CALL DSCAL( N, ZNORM, G, 1 ) + DWORK( 1 ) = DFLOAT( MINWRK - 5*N + LWAMAX ) + ZWORK( 1 ) = DCMPLX( MINZRK - 3*N + LZAMAX ) + RETURN + END IF + SVLAM = DLAMBD + DO 800 K = 1, M +C +C Store xD. +C + CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x. +C + DO 550 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 550 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute F. +C + DO 556 J = 1, N + DO 555 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 555 CONTINUE + 556 CONTINUE + CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, + $ ZWORK( IZ17+1 ), N ) +C +C Compute det( F ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DETF = CONE + DO 560 I = 1, N + DETF = DETF*ZWORK( IZ16+I ) + 560 CONTINUE +C +C Compute Finv. +C + CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) +C +C Compute phi. +C + DO 570 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 570 CONTINUE + IF( MR.GT.0 ) THEN + DO 580 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 580 CONTINUE + END IF + PROD = ONE + DO 590 I = 1, 2*MT + PROD = PROD*DWORK( IW25+I ) + 590 CONTINUE + TEMP = DREAL( DETF ) + IF( TEMP.LT.EPS ) TEMP = EPS + PHI = -LOG( TEMP ) - LOG( PROD ) +C +C Compute g. +C + DO 610 J = 1, MT + DO 600 I = 1, N*N + ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* + $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) + 600 CONTINUE + 610 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, + $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) + DO 620 I = 1, M-1 + DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - + $ ONE / ( ALPHA - DWORK( IW22+I ) ) + 620 CONTINUE + IF( MR.GT.0 ) THEN + DO 630 I = 1, MR + DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) + $ -ONE / ( TAU - DWORK( IW23+I ) ) + 630 CONTINUE + END IF + DO 640 I = 1, MT + DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - + $ DWORK( IW26+I ) + 640 CONTINUE +C +C Compute h. +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW27+1 ), MT, DWORK( IWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) + STSIZE = ONE +C +C Store hD. +C + CALL DCOPY( M-1, DWORK( IW27+1 ), 1, DWORK( IW28+1 ), 1 ) +C +C Determine stepsize. +C + L = 0 + DO 650 I = 1, M-1 + IF( DWORK( IW28+I ).GT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( DWORK( IW22+I ) - BETA ) / DWORK( IW28+I ) + ELSE + TEMP = MIN( TEMP, ( DWORK( IW22+I ) - BETA ) / + $ DWORK( IW28+I ) ) + END IF + END IF + 650 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + L = 0 + DO 660 I = 1, M-1 + IF( DWORK( IW28+I ).LT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( ALPHA - DWORK( IW22+I ) ) / + $ ( -DWORK( IW28+I ) ) + ELSE + TEMP = MIN( TEMP, ( ALPHA - DWORK( IW22+I ) ) / + $ ( -DWORK( IW28+I ) ) ) + END IF + END IF + 660 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + IF( MR.GT.0 ) THEN +C +C Store hG. +C + CALL DCOPY( MR, DWORK( IW27+M ), 1, DWORK( IW29+1 ), 1 ) +C +C Determine stepsize. +C + L = 0 + DO 670 I = 1, MR + IF( DWORK( IW29+I ).GT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( DWORK( IW23+I ) + TAU ) / + $ DWORK( IW29+I ) + ELSE + TEMP = MIN( TEMP, ( DWORK( IW23+I ) + TAU ) / + $ DWORK( IW29+I ) ) + END IF + END IF + 670 CONTINUE + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + L = 0 + DO 680 I = 1, MR + IF( DWORK( IW29+I ).LT.ZERO ) THEN + L = L + 1 + IF( L.EQ.1 ) THEN + TEMP = ( TAU - DWORK( IW23+I ) ) / + $ ( -DWORK( IW29+I ) ) + ELSE + TEMP = MIN( TEMP, ( TAU - DWORK( IW23+I ) ) / + $ ( -DWORK( IW29+I ) ) ) + END IF + END IF + 680 CONTINUE + END IF + IF( L.GT.0 ) STSIZE = MIN( STSIZE, TEMP ) + STSIZE = C4*STSIZE + IF( STSIZE.GE.TOL4 ) THEN +C +C Compute x_new. +C + DO 700 I = 1, MT + DWORK( IW20+I ) = X( I ) - STSIZE*DWORK( IW27+I ) + 700 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), + $ 1 ) + END IF +C +C Compute A(:) = A0 + AA*x_new. +C + DO 710 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) + 710 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute lambda*diag(B) - A. +C + DO 730 J = 1, N + DO 720 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = + $ -ZWORK( IZ7+I+(J-1)*N ) + END IF + 720 CONTINUE + 730 CONTINUE +C +C Compute eig( lambda*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, + $ SDIM, ZWORK( IZ16+1 ), ZWORK, N, + $ ZWORK( IZWRK+1 ), LZWORK-IZWRK, + $ DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 740 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 740 CONTINUE + END IF + DO 750 I = 1, N + DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) + 750 CONTINUE + DO 760 I = 1, M-1 + DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA + DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) + 760 CONTINUE + IF( MR.GT.0 ) THEN + DO 770 I = 1, MR + DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - + $ DWORK( IW23+I ) + 770 CONTINUE + END IF + PROD = ONE + DO 780 I = 1, N+2*MT + PROD = PROD*DWORK( IW30+I ) + 780 CONTINUE + IF( EMIN.LE.ZERO .OR. ( -LOG( PROD ) ).GE.PHI ) THEN + STSIZE = STSIZE / TEN + ELSE + CALL DCOPY( MT, DWORK( IW20+1 ), 1, X, 1 ) + END IF + END IF + IF( STSIZE.LT.TOL4 ) GO TO 810 + 800 CONTINUE +C + 810 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, X, 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, X( M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x. +C + DO 820 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( X( I ) ) + 820 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute F. +C + DO 840 J = 1, N + DO 830 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 830 CONTINUE + 840 CONTINUE + CALL ZLACPY( 'Full', N, N, ZWORK( IZ15+1 ), N, + $ ZWORK( IZ17+1 ), N ) +C +C Compute det( F ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DETF = CONE + DO 850 I = 1, N + DETF = DETF*ZWORK( IZ16+I ) + 850 CONTINUE +C +C Compute Finv. +C + CALL ZGETRF( N, N, ZWORK( IZ17+1 ), N, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL ZGETRI( N, ZWORK( IZ17+1 ), N, IWORK, ZWORK( IZWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) +C +C Compute the barrier function. +C + DO 860 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 860 CONTINUE + IF( MR.GT.0 ) THEN + DO 870 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 870 CONTINUE + END IF + PROD = ONE + DO 880 I = 1, 2*MT + PROD = PROD*DWORK( IW25+I ) + 880 CONTINUE + TEMP = DREAL( DETF ) + IF( TEMP.LT.EPS ) TEMP = EPS + PHI = -LOG( TEMP ) - LOG( PROD ) +C +C Compute the gradient of the barrier function. +C + DO 900 J = 1, MT + DO 890 I = 1, N*N + ZWORK( IZ18+I+(J-1)*N*N ) = DCMPLX( DLAMBD* + $ DWORK( IW9+I+(J-1)*N*N ) ) - ZWORK( IZ6+I+(J-1)*N*N ) + 890 CONTINUE + 900 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ18+1 ), N*N, + $ ZWORK( IZ17+1 ), 1, CZERO, ZWORK( IZ19+1 ), 1 ) + DO 910 I = 1, M-1 + DWORK( IW26+I ) = ONE / ( DWORK( IW22+I ) - BETA ) - + $ ONE / ( ALPHA - DWORK( IW22+I ) ) + 910 CONTINUE + IF( MR.GT.0 ) THEN + DO 920 I = 1, MR + DWORK( IW26+M-1+I ) = ONE / ( DWORK( IW23+I ) + TAU ) + $ -ONE / ( TAU - DWORK( IW23+I ) ) + 920 CONTINUE + END IF + DO 925 I = 1, MT + DWORK( IW26+I ) = -DREAL( ZWORK( IZ19+I ) ) - + $ DWORK( IW26+I ) + 925 CONTINUE +C +C Compute the Hessian of the barrier function. +C + CALL ZGEMM( 'N', 'N', N, N*MT, N, CONE, ZWORK( IZ17+1 ), N, + $ ZWORK( IZ18+1 ), N, CZERO, ZWORK( IZ20+1 ), N ) + + CALL DLASET( 'Full', MT, MT, ZERO, ZERO, DWORK( IW11+1 ), + $ MT ) + DO 960 K = 1, MT + CALL ZCOPY( N*N, ZWORK( IZ20+1+(K-1)*N*N ), 1, + $ ZWORK( IZ22+1 ), 1 ) + DO 940 J = 1, N + DO 930 I = 1, N + ZWORK( IZ23+I+(J-1)*N ) = + $ DCONJG( ZWORK( IZ22+J+(I-1)*N ) ) + 930 CONTINUE + 940 CONTINUE + CALL ZGEMV( 'C', N*N, K, CONE, ZWORK( IZ20+1 ), N*N, + $ ZWORK( IZ23+1 ), 1, CZERO, ZWORK( IZ24+1 ), + $ 1 ) + DO 950 J = 1, K + DWORK( IW11+K+(J-1)*MT ) = + $ DREAL( DCONJG( ZWORK( IZ24+J ) ) ) + 950 CONTINUE + 960 CONTINUE + DO 970 I = 1, M-1 + DWORK( IW10+I ) = ONE / ( DWORK( IW22+I ) - BETA )**2 + + $ ONE / ( ALPHA - DWORK( IW22+I ) )**2 + 970 CONTINUE + IF( MR.GT.0 ) THEN + DO 980 I = 1, MR + DWORK( IW10+M-1+I ) = + $ ONE / ( DWORK( IW23+I ) + TAU )**2 + + $ ONE / ( TAU - DWORK( IW23+I ) )**2 + 980 CONTINUE + END IF + DO 990 I = 1, MT + DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + + $ DWORK( IW10+I ) + 990 CONTINUE + DO 1100 J = 1, MT + DO 1000 I = 1, J + IF( I.NE.J ) THEN + T1 = DWORK( IW11+I+(J-1)*MT ) + T2 = DWORK( IW11+J+(I-1)*MT ) + DWORK( IW11+I+(J-1)*MT ) = T1 + T2 + DWORK( IW11+J+(I-1)*MT ) = T1 + T2 + END IF + 1000 CONTINUE + 1100 CONTINUE +C +C Compute norm( H ). +C + 1110 HNORM = DLANGE( 'F', MT, MT, DWORK( IW11+1 ), MT, DWORK ) +C +C Compute rcond( H ). +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + HNORM1 = DLANGE( '1', MT, MT, DWORK( IW31+1 ), MT, DWORK ) + CALL DSYTRF( 'U', MT, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) + CALL DSYCON( 'U', MT, DWORK( IW31+1 ), MT, IWORK, HNORM1, + $ RCOND, DWORK( IWRK+1 ), IWORK( MT+1 ), INFO2 ) + IF( RCOND.LT.TOL3 ) THEN + DO 1120 I = 1, MT + DWORK( IW11+I+(I-1)*MT ) = DWORK( IW11+I+(I-1)*MT ) + + $ HNORM*REGPAR + 1120 CONTINUE + GO TO 1110 + END IF +C +C Compute the tangent line to path of center. +C + CALL DCOPY( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + CALL DSYTRS( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW27+1 ), MT, INFO2 ) +C +C Check if x-h satisfies the Goldstein test. +C + GTEST = .FALSE. + DO 1130 I = 1, MT + DWORK( IW20+I ) = X( I ) - DWORK( IW27+I ) + 1130 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW20+1 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW20+M ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*x_new. +C + DO 1140 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW20+I ) ) + 1140 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute lambda*diag(B) - A. +C + DO 1160 J = 1, N + DO 1150 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DLAMBD* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1150 CONTINUE + 1160 CONTINUE +C +C Compute eig( lambda*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + DO 1190 I = 1, N + DWORK( IW30+I ) = DREAL( ZWORK( IZ16+I ) ) + 1190 CONTINUE + DO 1200 I = 1, M-1 + DWORK( IW30+N+I ) = DWORK( IW22+I ) - BETA + DWORK( IW30+N+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1200 CONTINUE + IF( MR.GT.0 ) THEN + DO 1210 I = 1, MR + DWORK( IW30+N+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW30+N+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1210 CONTINUE + END IF + EMIN = DWORK( IW30+1 ) + DO 1220 I = 1, N+2*MT + IF( DWORK( IW30+I ).LT.EMIN ) EMIN = DWORK( IW30+I ) + 1220 CONTINUE + IF( EMIN.LE.ZERO ) THEN + GTEST = .FALSE. + ELSE + PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + PROD = ONE + DO 1230 I = 1, N+2*MT + PROD = PROD*DWORK( IW30+I ) + 1230 CONTINUE + T1 = -LOG( PROD ) + T2 = PHI - C2*PP + T3 = PHI - C4*PP + IF( T1.GE.T3 .AND. T1.LT.T2 ) GTEST = .TRUE. + END IF +C +C Use x-h if Goldstein test is satisfied. Otherwise use +C Nesterov-Nemirovsky's stepsize length. +C + PP = DDOT( MT, DWORK( IW26+1 ), 1, DWORK( IW27+1 ), 1 ) + DELTA = SQRT( PP ) + IF( GTEST .OR. DELTA.LE.C3 ) THEN + DO 1240 I = 1, MT + X( I ) = X( I ) - DWORK( IW27+I ) + 1240 CONTINUE + ELSE + DO 1250 I = 1, MT + X( I ) = X( I ) - DWORK( IW27+I ) / ( ONE + DELTA ) + 1250 CONTINUE + END IF +C +C Analytic center is found if delta is sufficiently small. +C + IF( DELTA.LT.TOL5 ) GO TO 1260 + GO TO 810 +C +C Set yf. +C + 1260 DWORK( IW14+1 ) = DLAMBD + CALL DCOPY( MT, X, 1, DWORK( IW14+2 ), 1 ) +C +C Set yw. +C + CALL DCOPY( MT+1, DWORK( IW14+1 ), 1, DWORK( IW15+1 ), 1 ) +C +C Compute Fb. +C + DO 1280 J = 1, N + DO 1270 I = 1, N + ZWORK( IZ21+I+(J-1)*N ) = DCMPLX( DWORK( IW24+I ) )* + $ DCONJG( ZWORK( IZ17+J+(I-1)*N ) ) + 1270 CONTINUE + 1280 CONTINUE + CALL ZGEMV( 'C', N*N, MT, CONE, ZWORK( IZ20+1 ), N*N, + $ ZWORK( IZ21+1 ), 1, CZERO, ZWORK( IZ24+1 ), 1 ) + DO 1300 I = 1, MT + DWORK( IW32+I ) = DREAL( ZWORK( IZ24+I ) ) + 1300 CONTINUE +C +C Compute h1. +C + CALL DLACPY( 'Full', MT, MT, DWORK( IW11+1 ), MT, + $ DWORK( IW31+1 ), MT ) + CALL DSYSV( 'U', MT, 1, DWORK( IW31+1 ), MT, IWORK, + $ DWORK( IW32+1 ), MT, DWORK( IWRK+1 ), + $ LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + LWAMAX = MAX( LWA, LWAMAX ) +C +C Compute hn. +C + HN = DLANGE( 'F', MT, 1, DWORK( IW32+1 ), MT, DWORK ) +C +C Compute y. +C + DWORK( IW13+1 ) = DLAMBD - C / HN + DO 1310 I = 1, MT + DWORK( IW13+1+I ) = X( I ) + C*DWORK( IW32+I ) / HN + 1310 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y(2:mt+1). +C + DO 1320 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) + 1320 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute B = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute y(1)*diag(B) - A. +C + DO 1340 J = 1, N + DO 1330 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1330 CONTINUE + 1340 CONTINUE +C +C Compute eig( y(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1350 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1350 CONTINUE + END IF + POS = .TRUE. + DO 1360 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1360 CONTINUE + IF( MR.GT.0 ) THEN + DO 1370 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1370 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1380 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1380 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + 1390 IF( POS ) THEN +C +C Set y2 = y. +C + CALL DCOPY( MT+1, DWORK( IW13+1 ), 1, DWORK( IW17+1 ), 1 ) +C +C Compute y = y + 1.5*( y - yw ). +C + DO 1400 I = 1, MT+1 + DWORK( IW13+I ) = DWORK( IW13+I ) + + $ C5*( DWORK( IW13+I ) - DWORK( IW15+I ) ) + 1400 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW13+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW13+M+1 ), 1, + $ DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y(2:mt+1). +C + DO 1420 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW13+1+I ) ) + 1420 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Set yw = y2. +C + CALL DCOPY( MT+1, DWORK( IW17+1 ), 1, DWORK( IW15+1 ), 1 ) +C +C Compute y(1)*diag(B) - A. +C + DO 1440 J = 1, N + DO 1430 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW13+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1430 CONTINUE + 1440 CONTINUE +C +C Compute eig( y(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1450 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1450 CONTINUE + END IF + POS = .TRUE. + DO 1460 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1460 CONTINUE + IF( MR.GT.0 ) THEN + DO 1470 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1470 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1480 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1480 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + GO TO 1390 + END IF + 1490 CONTINUE +C +C Set y1 = ( y + yw ) / 2. +C + DO 1500 I = 1, MT+1 + DWORK( IW16+I ) = ( DWORK( IW13+I ) + DWORK( IW15+I ) ) + $ / TWO + 1500 CONTINUE +C +C Store xD. +C + CALL DCOPY( M-1, DWORK( IW16+2 ), 1, DWORK( IW22+1 ), 1 ) + IF( MR.GT.0 ) THEN +C +C Store xG. +C + CALL DCOPY( MR, DWORK( IW16+M+1 ), 1, DWORK( IW23+1 ), 1 ) + END IF +C +C Compute A(:) = A0 + AA*y1(2:mt+1). +C + DO 1510 I = 1, MT + ZWORK( IZ10+I ) = DCMPLX( DWORK( IW16+1+I ) ) + 1510 CONTINUE + CALL ZCOPY( N*N, ZWORK( IZ5+1 ), 1, ZWORK( IZ7+1 ), 1 ) + CALL ZGEMV( 'N', N*N, MT, CONE, ZWORK( IZ6+1 ), N*N, + $ ZWORK( IZ10+1 ), 1, CONE, ZWORK( IZ7+1 ), 1 ) +C +C Compute diag( B ) = B0d + BBd*xD. +C + CALL DCOPY( N, DWORK( IW7+1 ), 1, DWORK( IW24+1 ), 1 ) + CALL DGEMV( 'N', N, M-1, ONE, DWORK( IW8+1 ), N, + $ DWORK( IW22+1 ), 1, ONE, DWORK( IW24+1 ), 1 ) +C +C Compute y1(1)*diag(B) - A. +C + DO 1530 J = 1, N + DO 1520 I = 1, N + IF( I.EQ.J ) THEN + ZWORK( IZ15+I+(I-1)*N ) = DCMPLX( DWORK( IW16+1 )* + $ DWORK( IW24+I ) ) - ZWORK( IZ7+I+(I-1)*N ) + ELSE + ZWORK( IZ15+I+(J-1)*N ) = -ZWORK( IZ7+I+(J-1)*N ) + END IF + 1520 CONTINUE + 1530 CONTINUE +C +C Compute eig( y1(1)*diag(B)-A ). +C + CALL ZGEES( 'N', 'N', SELECT, N, ZWORK( IZ15+1 ), N, SDIM, + $ ZWORK( IZ16+1 ), ZWORK, N, ZWORK( IZWRK+1 ), + $ LZWORK-IZWRK, DWORK( IWRK+1 ), BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LZA = INT( ZWORK( IZWRK+1 ) ) + LZAMAX = MAX( LZA, LZAMAX ) + EMIN = DREAL( ZWORK( IZ16+1 ) ) + IF( N.GT.1 ) THEN + DO 1540 I = 2, N + IF( DREAL( ZWORK( IZ16+I ) ).LT.EMIN ) + $ EMIN = DREAL( ZWORK( IZ16+I ) ) + 1540 CONTINUE + END IF + POS = .TRUE. + DO 1550 I = 1, M-1 + DWORK( IW25+I ) = DWORK( IW22+I ) - BETA + DWORK( IW25+M-1+I ) = ALPHA - DWORK( IW22+I ) + 1550 CONTINUE + IF( MR.GT.0 ) THEN + DO 1560 I = 1, MR + DWORK( IW25+2*(M-1)+I ) = DWORK( IW23+I ) + TAU + DWORK( IW25+2*(M-1)+MR+I ) = TAU - DWORK( IW23+I ) + 1560 CONTINUE + END IF + TEMP = DWORK( IW25+1 ) + DO 1570 I = 2, 2*MT + IF( DWORK( IW25+I ).LT.TEMP ) TEMP = DWORK( IW25+I ) + 1570 CONTINUE + IF( TEMP.LE.ZERO .OR. EMIN.LE.ZERO ) POS = .FALSE. + IF( POS ) THEN +C +C Set yw = y1. +C + CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW15+1 ), 1 ) + ELSE +C +C Set y = y1. +C + CALL DCOPY( MT+1, DWORK( IW16+1 ), 1, DWORK( IW13+1 ), 1 ) + END IF + DO 1580 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW15+I ) + 1580 CONTINUE + YNORM1 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) + DO 1590 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW13+I ) - DWORK( IW14+I ) + 1590 CONTINUE + YNORM2 = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) + IF( YNORM1.LT.YNORM2*THETA ) GO TO 1600 + GO TO 1490 +C +C Compute c. +C + 1600 DO 1610 I = 1, MT+1 + DWORK( IW33+I ) = DWORK( IW15+I ) - DWORK( IW14+I ) + 1610 CONTINUE + C = DLANGE( 'F', MT+1, 1, DWORK( IW33+1 ), MT+1, DWORK ) +C +C Set x = yw(2:mt+1). +C + CALL DCOPY( MT, DWORK( IW15+2 ), 1, X, 1 ) + GO TO 390 +C +C *** Last line of AB13MD *** + END diff --git a/mex/sources/libslicot/AB8NXZ.f b/mex/sources/libslicot/AB8NXZ.f new file mode 100644 index 000000000..9ec0da563 --- /dev/null +++ b/mex/sources/libslicot/AB8NXZ.f @@ -0,0 +1,456 @@ + SUBROUTINE AB8NXZ( N, M, P, RO, SIGMA, SVLMAX, ABCD, LDABCD, + $ NINFZ, INFZ, KRONL, MU, NU, NKROL, TOL, IWORK, + $ DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) system +C ( B A ) +C ( D C ) +C an (NU+MU)-by-(M+NU) "reduced" system +C ( B' A') +C ( D' C') +C having the same transmission zeros but with D' of full row rank. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of state variables. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C RO (input/output) INTEGER +C On entry, +C = P for the original system; +C = MAX(P-M, 0) for the pertransposed system. +C On exit, RO contains the last computed rank. +C +C SIGMA (input/output) INTEGER +C On entry, +C = 0 for the original system; +C = M for the pertransposed system. +C On exit, SIGMA contains the last computed value sigma in +C the algorithm. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) COMPLEX*16 array, dimension (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound input matrix of the system. +C On exit, the leading (NU+MU)-by-(M+NU) part of this array +C contains the reduced compound input matrix of the system. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C NINFZ (input/output) INTEGER +C On entry, the currently computed number of infinite zeros. +C It should be initialized to zero on the first call. +C NINFZ >= 0. +C On exit, the number of infinite zeros. +C +C INFZ (input/output) INTEGER array, dimension (N) +C On entry, INFZ(i) must contain the current number of +C infinite zeros of degree i, where i = 1,2,...,N, found in +C the previous call(s) of the routine. It should be +C initialized to zero on the first call. +C On exit, INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,N. +C +C KRONL (input/output) INTEGER array, dimension (N+1) +C On entry, this array must contain the currently computed +C left Kronecker (row) indices found in the previous call(s) +C of the routine. It should be initialized to zero on the +C first call. +C On exit, the leading NKROL elements of this array contain +C the left Kronecker (row) indices. +C +C MU (output) INTEGER +C The normal rank of the transfer function matrix of the +C original system. +C +C NU (output) INTEGER +C The dimension of the reduced system matrix and the number +C of (finite) invariant zeros if D' is invertible. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (2*MAX(M,P)) +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX( 1, MIN(P,M) + MAX(3*M-1,N), +C MIN(P,N) + MAX(3*P-1,N+P,N+M) ). +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Svaricek, F. +C Computation of the Structural Invariants of Linear +C Multivariable Systems with an Extended Version of +C the Program ZEROS. +C System & Control Letters, 6, pp. 261-266, 1985. +C +C [2] Emami-Naeini, A. and Van Dooren, P. +C Computation of Zeros of Linear Multivariable Systems. +C Automatica, 18, pp. 415-430, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008 with suggestions from P. Gahinet, +C The MathWorks. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, unitary transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION DZERO + PARAMETER ( DZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDABCD, LZWORK, M, MU, N, NINFZ, NKROL, + $ NU, P, RO, SIGMA + DOUBLE PRECISION SVLMAX, TOL +C .. Array Arguments .. + INTEGER INFZ(*), IWORK(*), KRONL(*) + COMPLEX*16 ABCD(LDABCD,*), ZWORK(*) + DOUBLE PRECISION DWORK(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I1, IK, IROW, ITAU, IZ, JWORK, MM1, MNTAU, MNU, + $ MPM, NB, NP, RANK, RO1, TAU, WRKOPT + COMPLEX*16 TC +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL MB3OYZ, MB3PYZ, XERBLA, ZLAPMT, ZLARFG, ZLASET, + $ ZLATZM, ZUNMQR, ZUNMRQ +C .. Intrinsic Functions .. + INTRINSIC DCONJG, INT, MAX, MIN +C .. Executable Statements .. +C + NP = N + P + MPM = MIN( P, M ) + INFO = 0 + LQUERY = ( LZWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( RO.NE.P .AND. RO.NE.MAX( P-M, 0 ) ) THEN + INFO = -4 + ELSE IF( SIGMA.NE.0 .AND. SIGMA.NE.M ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.DZERO ) THEN + INFO = -6 + ELSE IF( LDABCD.LT.MAX( 1, NP ) ) THEN + INFO = -8 + ELSE IF( NINFZ.LT.0 ) THEN + INFO = -9 + ELSE + JWORK = MAX( 1, MPM + MAX( 3*M - 1, N ), + $ MIN( P, N ) + MAX( 3*P - 1, NP, N+M ) ) + IF( LQUERY ) THEN + IF( M.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', P, N, MPM, + $ -1 ) ) + WRKOPT = MAX( JWORK, MPM + MAX( 1, N )*NB ) + ELSE + WRKOPT = JWORK + END IF + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', NP, N, MIN( P, N ), + $ -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, NP )*NB ) + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'LN', N, M+N, + $ MIN( P, N ), -1 ) ) + WRKOPT = MAX( WRKOPT, MIN( P, N ) + MAX( 1, M+N )*NB ) + ELSE IF( LZWORK.LT.JWORK ) THEN + INFO = -19 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AB8NXZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C + MU = P + NU = N +C + IZ = 0 + IK = 1 + MM1 = M + 1 + ITAU = 1 + NKROL = 0 + WRKOPT = 1 +C +C Main reduction loop: +C +C M NU M NU +C NU [ B A ] NU [ B A ] +C MU [ D C ] --> SIGMA [ RD C1 ] (SIGMA = rank(D) = +C TAU [ 0 C2 ] row size of RD) +C +C M NU-RO RO +C NU-RO [ B1 A11 A12 ] +C --> RO [ B2 A21 A22 ] (RO = rank(C2) = +C SIGMA [ RD C11 C12 ] col size of LC) +C TAU [ 0 0 LC ] +C +C M NU-RO +C NU-RO [ B1 A11 ] NU := NU - RO +C [----------] MU := RO + SIGMA +C --> RO [ B2 A21 ] D := [B2;RD] +C SIGMA [ RD C11 ] C := [A21;C11] +C + 20 IF ( MU.EQ.0 ) + $ GO TO 80 +C +C (Note: Comments in the code beginning "xWorkspace:", where x is +C I, D, or C, describe the minimal amount of integer, real and +C complex workspace needed at that point in the code, respectively, +C as well as the preferred amount for good performance.) +C + RO1 = RO + MNU = M + NU + IF ( M.GT.0 ) THEN + IF ( SIGMA.NE.0 ) THEN + IROW = NU + 1 +C +C Compress rows of D. First exploit triangular shape. +C CWorkspace: need M+N-1. +C + DO 40 I1 = 1, SIGMA + CALL ZLARFG( RO+1, ABCD(IROW,I1), ABCD(IROW+1,I1), 1, + $ TC ) + CALL ZLATZM( 'L', RO+1, MNU-I1, ABCD(IROW+1,I1), 1, + $ DCONJG( TC ), ABCD(IROW,I1+1), + $ ABCD(IROW+1,I1+1), LDABCD, ZWORK ) + IROW = IROW + 1 + 40 CONTINUE + CALL ZLASET( 'Lower', RO+SIGMA-1, SIGMA, ZERO, ZERO, + $ ABCD(NU+2,1), LDABCD ) + END IF +C +C Continue with Householder with column pivoting. +C +C The rank of D is the number of (estimated) singular values +C that are greater than TOL * MAX(SVLMAX,EMSV). This number +C includes the singular values of the first SIGMA columns. +C IWorkspace: need M; +C RWorkspace: need 2*M; +C CWorkspace: need min(RO1,M) + 3*M - 1. RO1 <= P. +C + IF ( SIGMA.LT.M ) THEN + JWORK = ITAU + MIN( RO1, M ) + I1 = SIGMA + 1 + IROW = NU + I1 + CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,I1), LDABCD, TOL, + $ SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), DWORK, + $ ZWORK(JWORK), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*M - 2 ) +C +C Apply the column permutations to matrices B and part of D. +C + CALL ZLAPMT( .TRUE., NU+SIGMA, M-SIGMA, ABCD(1,I1), LDABCD, + $ IWORK ) +C + IF ( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C CWorkspace: need min(RO1,M) + NU; +C prefer min(RO1,M) + NU*NB. +C + CALL ZUNMQR( 'Left', 'Conjugate', RO1, NU, RANK, + $ ABCD(IROW,I1), LDABCD, ZWORK(ITAU), + $ ABCD(IROW,MM1), LDABCD, ZWORK(JWORK), + $ LZWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) + IF ( RO1.GT.1 ) + $ CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, + $ ZERO, ABCD(IROW+1,I1), LDABCD ) + RO1 = RO1 - RANK + END IF + END IF + END IF +C + TAU = RO1 + SIGMA = MU - TAU +C +C Determination of the orders of the infinite zeros. +C + IF ( IZ.GT.0 ) THEN + INFZ(IZ) = INFZ(IZ) + RO - TAU + NINFZ = NINFZ + IZ*( RO - TAU ) + END IF + IF ( RO1.EQ.0 ) + $ GO TO 80 + IZ = IZ + 1 +C + IF ( NU.LE.0 ) THEN + MU = SIGMA + NU = 0 + RO = 0 + ELSE +C +C Compress the columns of C2 using RQ factorization with row +C pivoting, P * C2 = R * Q. +C + I1 = NU + SIGMA + 1 + MNTAU = MIN( TAU, NU ) + JWORK = ITAU + MNTAU +C +C The rank of C2 is the number of (estimated) singular values +C greater than TOL * MAX(SVLMAX,EMSV). +C IWorkspace: need TAU; +C RWorkspace: need 2*TAU; +C CWorkspace: need min(TAU,NU) + 3*TAU - 1. +C + CALL MB3PYZ( TAU, NU, ABCD(I1,MM1), LDABCD, TOL, SVLMAX, RANK, + $ SVAL, IWORK, ZWORK(ITAU), DWORK, ZWORK(JWORK), + $ INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*TAU - 1 ) + IF ( RANK.GT.0 ) THEN + IROW = I1 + TAU - RANK +C +C Apply Q' to the first NU columns of [A; C1] from the right. +C CWorkspace: need min(TAU,NU) + NU + SIGMA; SIGMA <= P; +C prefer min(TAU,NU) + (NU + SIGMA)*NB. +C + CALL ZUNMRQ( 'Right', 'ConjTranspose', I1-1, NU, RANK, + $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), + $ ABCD(1,MM1), LDABCD, ZWORK(JWORK), + $ LZWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C +C Apply Q to the first NU rows and M + NU columns of [ B A ] +C from the left. +C CWorkspace: need min(TAU,NU) + M + NU; +C prefer min(TAU,NU) + (M + NU)*NB. +C + CALL ZUNMRQ( 'Left', 'NoTranspose', NU, MNU, RANK, + $ ABCD(IROW,MM1), LDABCD, ZWORK(MNTAU-RANK+1), + $ ABCD, LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C + CALL ZLASET( 'Full', RANK, NU-RANK, ZERO, ZERO, + $ ABCD(IROW,MM1), LDABCD ) + IF ( RANK.GT.1 ) + $ CALL ZLASET( 'Lower', RANK-1, RANK-1, ZERO, ZERO, + $ ABCD(IROW+1,MM1+NU-RANK), LDABCD ) + END IF +C + RO = RANK + END IF +C +C Determine the left Kronecker indices (row indices). +C + KRONL(IK) = KRONL(IK) + TAU - RO + NKROL = NKROL + KRONL(IK) + IK = IK + 1 +C +C C and D are updated to [A21 ; C11] and [B2 ; RD]. +C + NU = NU - RO + MU = SIGMA + RO + IF ( RO.NE.0 ) + $ GO TO 20 +C + 80 CONTINUE + ZWORK(1) = WRKOPT + RETURN +C *** Last line of AB8NXZ *** + END diff --git a/mex/sources/libslicot/AG07BD.f b/mex/sources/libslicot/AG07BD.f new file mode 100644 index 000000000..5a7ab4c5a --- /dev/null +++ b/mex/sources/libslicot/AG07BD.f @@ -0,0 +1,273 @@ + SUBROUTINE AG07BD( JOBE, N, M, A, LDA, E, LDE, B, LDB, C, LDC, + $ D, LDD, AI, LDAI, EI, LDEI, BI, LDBI, CI, LDCI, + $ DI, LDDI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the inverse (Ai-lambda*Ei,Bi,Ci,Di) of a given +C descriptor system (A-lambda*E,B,C,D). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBE CHARACTER*1 +C Specifies whether E is a general square or an identity +C matrix as follows: +C = 'G': E is a general square matrix; +C = 'I': E is the identity matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the square matrices A and E; +C also the number of rows of matrix B and the number of +C columns of matrix C. N >= 0. +C +C M (input) INTEGER +C The number of system inputs and outputs, i.e., the number +C of columns of matrices B and D and the number of rows of +C matrices C and D. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the original system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C If JOBE = 'G', the leading N-by-N part of this array must +C contain the descriptor matrix E of the original system. +C If JOBE = 'I', then E is assumed to be the identity +C matrix and is not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. +C LDE >= MAX(1,N), if JOBE = 'G'; +C LDE >= 1, if JOBE = 'I'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the original system. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading M-by-N part of this array must contain the +C output matrix C of the original system. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,M). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading M-by-M part of this array must contain the +C feedthrough matrix D of the original system. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,M). +C +C AI (output) DOUBLE PRECISION array, dimension (LDAI,N+M) +C The leading (N+M)-by-(N+M) part of this array contains +C the state matrix Ai of the inverse system. +C If LDAI = LDA >= N+M, then AI and A can share the same +C storage locations. +C +C LDAI INTEGER +C The leading dimension of the array AI. +C LDAI >= MAX(1,N+M). +C +C EI (output) DOUBLE PRECISION array, dimension (LDEI,N+M) +C The leading (N+M)-by-(N+M) part of this array contains +C the descriptor matrix Ei of the inverse system. +C If LDEI = LDE >= N+M, then EI and E can share the same +C storage locations. +C +C LDEI INTEGER +C The leading dimension of the array EI. +C LDEI >= MAX(1,N+M). +C +C BI (output) DOUBLE PRECISION array, dimension (LDBI,M) +C The leading (N+M)-by-M part of this array contains +C the input matrix Bi of the inverse system. +C If LDBI = LDB >= N+M, then BI and B can share the same +C storage locations. +C +C LDBI INTEGER +C The leading dimension of the array BI. +C LDBI >= MAX(1,N+M). +C +C CI (output) DOUBLE PRECISION array, dimension (LDCI,N+M) +C The leading M-by-(N+M) part of this array contains +C the output matrix Ci of the inverse system. +C If LDCI = LDC, CI and C can share the same storage +C locations. +C +C LDCI INTEGER +C The leading dimension of the array CI. LDCI >= MAX(1,M). +C +C DI (output) DOUBLE PRECISION array, dimension (LDDI,M) +C The leading M-by-M part of this array contains +C the feedthrough matrix Di = 0 of the inverse system. +C DI and D can share the same storage locations. +C +C LDDI INTEGER +C The leading dimension of the array DI. LDDI >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices of the inverse system are computed with the formulas +C +C ( E 0 ) ( A B ) ( 0 ) +C Ei = ( ) , Ai = ( ) , Bi = ( ), +C ( 0 0 ) ( C D ) ( -I ) +C +C Ci = ( 0 I ), Di = 0. +C +C FURTHER COMMENTS +C +C The routine does not perform an invertibility test. This check can +C be performed by using the SLICOT routines AB08NX or AG08BY. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, July 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C KEYWORDS +C +C Descriptor system, inverse system, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBE + INTEGER INFO, LDA, LDAI, LDB, LDBI, LDC, LDCI, + $ LDD, LDDI, LDE, LDEI, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), AI(LDAI,*), B(LDB,*), BI(LDBI,*), + $ C(LDC,*), CI(LDCI,*), D(LDD,*), DI(LDDI,*), + $ E(LDE,*), EI(LDEI,*) +C .. Local Scalars .. + LOGICAL UNITE +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + UNITE = LSAME( JOBE, 'I' ) + IF( .NOT. ( LSAME( JOBE, 'G' ) .OR. UNITE ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDE.LT.1 .OR. ( .NOT.UNITE .AND. LDE.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDAI.LT.MAX( 1, N+M ) ) THEN + INFO = -15 + ELSE IF( LDEI.LT.MAX( 1, N+M ) ) THEN + INFO = -17 + ELSE IF( LDBI.LT.MAX( 1, N+M ) ) THEN + INFO = -19 + ELSE IF( LDCI.LT.MAX( 1, M ) ) THEN + INFO = -21 + ELSE IF( LDDI.LT.MAX( 1, M ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AG07BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C +C Form Ai. +C + CALL DLACPY( 'Full', N, N, A, LDA, AI, LDAI ) + CALL DLACPY( 'Full', M, N, C, LDC, AI(N+1,1), LDAI ) + CALL DLACPY( 'Full', N, M, B, LDB, AI(1,N+1), LDAI ) + CALL DLACPY( 'Full', M, M, D, LDD, AI(N+1,N+1), LDAI ) +C +C Form Ei. +C + IF( UNITE ) THEN + CALL DLASET( 'Full', N+M, N, ZERO, ONE, EI, LDEI ) + ELSE + CALL DLACPY( 'Full', N, N, E, LDE, EI, LDEI ) + CALL DLASET( 'Full', M, N, ZERO, ZERO, EI(N+1,1), LDEI ) + END IF + CALL DLASET( 'Full', N+M, M, ZERO, ZERO, EI(1,N+1), LDEI ) +C +C Form Bi. +C + CALL DLASET( 'Full', N, M, ZERO, ZERO, BI, LDBI ) + CALL DLASET( 'Full', M, M, ZERO, -ONE, BI(N+1,1), LDBI ) +C +C Form Ci. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, CI, LDCI ) + CALL DLASET( 'Full', M, M, ZERO, ONE, CI(1,N+1), LDCI ) +C +C Set Di. +C + CALL DLASET( 'Full', M, M, ZERO, ZERO, DI, LDDI ) +C + RETURN +C *** Last line of AG07BD *** + END diff --git a/mex/sources/libslicot/AG08BD.f b/mex/sources/libslicot/AG08BD.f new file mode 100644 index 000000000..ff0cdcc81 --- /dev/null +++ b/mex/sources/libslicot/AG08BD.f @@ -0,0 +1,628 @@ + SUBROUTINE AG08BD( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, + $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the system pencil +C +C ( A-lambda*E B ) +C S(lambda) = ( ) +C ( C D ) +C +C a regular pencil Af-lambda*Ef which has the finite Smith zeros of +C S(lambda) as generalized eigenvalues. The routine also computes +C the orders of the infinite Smith zeros and determines the singular +C and infinite Kronecker structure of system pencil, i.e., the right +C and left Kronecker indices, and the multiplicities of infinite +C eigenvalues. +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the system +C matrix as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A of the system. +C On exit, the leading NFZ-by-NFZ part of this array +C contains the matrix Af of the reduced pencil. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E of the system. +C On exit, the leading NFZ-by-NFZ part of this array +C contains the matrix Ef of the reduced pencil. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B of the system. +C On exit, this matrix does not contain useful information. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0; +C LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C of the system. +C On exit, this matrix does not contain useful information. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NFZ (output) INTEGER +C The number of finite zeros. +C +C NRANK (output) INTEGER +C The normal rank of the system pencil. +C +C NIZ (output) INTEGER +C The number of infinite zeros. +C +C DINFZ (output) INTEGER +C The maximal multiplicity of infinite Smith zeros. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NINFE (output) INTEGER +C The number of elementary infinite blocks. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N+1) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors of +C degree i in the Smith form, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (N+M+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) +C The leading NINFE elements of INFE contain the +C multiplicities of infinite eigenvalues. +C +C KRONL (output) INTEGER array, dimension (L+P+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL <= 0, then default tolerances are +C used instead, as follows: TOLDEF = L*N*EPS in TG01FD +C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS +C in the rest, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension N+max(1,M) +C On output, IWORK(1) contains the normal rank of the +C transfer function matrix. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 4*(L+N), LDW ), if EQUIL = 'S', +C LDWORK >= LDW, if EQUIL = 'N', where +C LDW = max(L+P,M+N)*(M+N) + max(1,5*max(L+P,M+N)). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a descriptor +C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which +C has the finite zeros of the system as generalized eigenvalues. +C The procedure has the following main computational steps: +C +C (a) construct the (L+P)-by-(N+M) system pencil +C +C S(lambda) = ( B A )-lambda*( 0 E ); +C ( D C ) ( 0 0 ) +C +C (b) reduce S(lambda) to S1(lambda) with the same finite +C zeros and right Kronecker structure but with E +C upper triangular and nonsingular; +C +C (c) reduce S1(lambda) to S2(lambda) with the same finite +C zeros and right Kronecker structure but with D of +C full row rank; +C +C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros +C and with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C +C S3(lambda) = (A-lambda*E B) in order to reduce it to +C ( C D) +C +C (Af-lambda*Ef X), with Y and Ef square invertible; +C ( 0 Y) +C +C (f) compute the right and left Kronecker indices of the system +C matrix, which together with the multiplicities of the +C finite and infinite eigenvalues constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] P. Misra, P. Van Dooren and A. Varga. +C Computation of structural invariants of generalized +C state-space systems. +C Automatica, 30, pp. 1921-1936, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [1]). +C +C FURTHER COMMENTS +C +C In order to compute the finite Smith zeros of the system +C explicitly, a call to this routine may be followed by a +C call to the LAPACK Library routines DGEGV or DGGEV. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C May 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, +C Jan. 2009, Mar. 2009, Apr. 2009. +C A. Varga, DLR Oberpfaffenhofen, Nov. 1999, Feb. 2002, Mar. 2002. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LDWORK, + $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), E(LDE,*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, + $ LABCD2, LDABCD, LDW, MM, MU, N2, NB, NN, NSINFE, + $ NU, NUMU, PP, WRKOPT + DOUBLE PRECISION SVLMAX, TOLER +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL AG08BY, DLACPY, DLASET, DORMRZ, DTZRZF, MA02BD, + $ MA02CD, TB01XD, TG01AD, TG01FD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LDABCD = MAX( L+P, N+M ) + LABCD2 = LDABCD*( N+M ) + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -27 + ELSE + I0 = MIN( L+P, M+N ) + I1 = MIN( L, N ) + II = MIN( M, P ) + LDW = LABCD2 + MAX( 1, 5*LDABCD ) + IF( LEQUIL ) + $ LDW = MAX( 4*( L + N ), LDW ) + IF( LQUERY ) THEN + CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, + $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, + $ IWORK, DWORK, -1, INFO ) + WRKOPT = MAX( LDW, INT( DWORK(1) ) ) + SVLMAX = ZERO + CALL AG08BY( .TRUE., I1, M+N, P+L, SVLMAX, DWORK, LDABCD+I1, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOL, IWORK, DWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) + CALL AG08BY( .FALSE., I1, II, M+N, SVLMAX, DWORK, LDABCD+I1, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOL, IWORK, DWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) ) + NB = ILAENV( 1, 'ZGERQF', ' ', II, I1+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, LABCD2 + II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RT', I1, I1+II, II, + $ -1 ) ) + WRKOPT = MAX( WRKOPT, LABCD2 + II + I1*NB ) + ELSE IF( LDWORK.LT.LDW ) THEN + INFO = -30 + END IF + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AG08BD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C + NIZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF( MAX( L, N, M, P ).EQ.0 ) THEN + NFZ = 0 + DINFZ = 0 + NINFE = 0 + NRANK = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + WRKOPT = 1 + KABCD = 1 + JWORK = KABCD + LABCD2 +C +C If required, balance the system pencil. +C Workspace: need 4*(L+N). +C + IF( LEQUIL ) THEN + CALL TG01AD( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, + $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) + WRKOPT = 4*(L+N) + END IF + SVLMAX = DLANGE( 'Frobenius', L, N, E, LDE, DWORK ) +C +C Reduce the system matrix to QR form, +C +C ( A11-lambda*E11 A12 B1 ) +C ( A21 A22 B2 ) , +C ( C1 C2 D ) +C +C with E11 invertible and upper triangular. +C Real workspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); +C prefer larger. +C Integer workspace: N. +C + CALL TG01FD( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Construct the system pencil +C +C MM NN +C ( B1 A12 A11-lambda*E11 ) NN +C S1(lambda) = ( B2 A22 A21 ) L-NN +C ( D C2 C1 ) P +C +C of dimension (L+P)-by-(M+N). +C Workspace: need LABCD2 = max( L+P, N+M )*( N+M ). +C + N2 = N - NN + MM = M + N2 + PP = P + ( L - NN ) + CALL DLACPY( 'Full', L, M, B, LDB, DWORK(KABCD), LDABCD ) + CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KABCD+L), LDABCD ) + CALL DLACPY( 'Full', L, N2, A(1,NN+1), LDA, + $ DWORK(KABCD+LDABCD*M), LDABCD ) + CALL DLACPY( 'Full', P, N2, C(1,NN+1), LDC, + $ DWORK(KABCD+LDABCD*M+L), LDABCD ) + CALL DLACPY( 'Full', L, NN, A, LDA, + $ DWORK(KABCD+LDABCD*MM), LDABCD ) + CALL DLACPY( 'Full', P, NN, C, LDC, + $ DWORK(KABCD+LDABCD*MM+L), LDABCD ) +C +C If required, set tolerance. +C + TOLER = TOL + IF( TOLER.LE.ZERO ) THEN + TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) + END IF + SVLMAX = MAX( SVLMAX, + $ DLANGE( 'Frobenius', NN+PP, NN+MM, DWORK(KABCD), + $ LDABCD, DWORK(JWORK) ) ) +C +C Extract the reduced pencil S2(lambda) +C +C ( Bc Ac-lambda*Ec ) +C ( Dc Cc ) +C +C having the same finite Smith zeros as the system pencil +C S(lambda) but with Dc, a MU-by-MM full row rank +C left upper trapezoidal matrix, and Ec, an NU-by-NU +C upper triangular nonsingular matrix. +C +C Real workspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), +C 5*(P+L), 1 ) + LABCD2; +C prefer larger. +C Integer workspace: MM, MM <= M+N; PP <= P+L. +C + CALL AG08BY( .TRUE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Set the number of simple (nondynamic) infinite eigenvalues +C and the normal rank of the system pencil. +C + NSINFE = MU + NRANK = NN + MU +C +C Pertranspose the system. +C + CALL TB01XD( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), + $ DWORK(KABCD+LDABCD*MM), LDABCD, + $ DWORK(KABCD), LDABCD, + $ DWORK(KABCD+LDABCD*MM+NU), LDABCD, + $ DWORK(KABCD+NU), LDABCD, INFO ) + CALL MA02BD( 'Right', NU+MM, MM, DWORK(KABCD), LDABCD ) + CALL MA02BD( 'Left', MM, NU+MM, DWORK(KABCD+NU), LDABCD ) + CALL MA02CD( NU, 0, MAX( 0, NU-1 ), E, LDE ) +C + IF( MU.NE.MM ) THEN + NN = NU + PP = MM + MM = MU + KABCD = KABCD + ( PP - MM )*LDABCD +C +C Extract the reduced pencil S3(lambda), +C +C ( Br Ar-lambda*Er ) , +C ( Dr Cr ) +C +C having the same finite Smith zeros as the pencil S(lambda), +C but with Dr, an MU-by-MU invertible upper triangular matrix, +C and Er, an NU-by-NU upper triangular nonsingular matrix. +C +C Workspace: need max( 1, 5*(M+N) ) + LABCD2. +C prefer larger. +C No integer workspace necessary. +C + CALL AG08BY( .FALSE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD, + $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, + $ TOLER, IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( Br Ar-lambda*Er ) +C ( Dr Cr ) +C in order to reduce it to +C ( * Af-lambda*Ef ) +C ( Y 0 ) +C with Y and Ef square invertible. +C +C Compute Af by reducing ( Br Ar ) to ( * Af ) . +C ( Dr Cr ) ( Y 0 ) +C + NUMU = NU + MU + IPD = KABCD + NU + ITAU = JWORK + JWORK = ITAU + MU +C +C Workspace: need LABCD2 + 2*min(M,P); +C prefer LABCD2 + min(M,P) + min(M,P)*NB. +C + CALL DTZRZF( MU, NUMU, DWORK(IPD), LDABCD, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need LABCD2 + min(M,P) + min(L,N); +C prefer LABCD2 + min(M,P) + min(L,N)*NB. +C + CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, + $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), + $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Save Af. +C + CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, A, + $ LDA ) +C +C Compute Ef by applying the saved transformations from previous +C reduction to ( 0 Er ) . +C + CALL DLASET( 'Full', NU, MU, ZERO, ZERO, DWORK(KABCD), LDABCD ) + CALL DLACPY( 'Full', NU, NU, E, LDE, DWORK(KABCD+LDABCD*MU), + $ LDABCD ) +C + CALL DORMRZ( 'Right', 'Transpose', NU, NUMU, MU, NU, + $ DWORK(IPD), LDABCD, DWORK(ITAU), DWORK(KABCD), + $ LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C +C Save Ef. +C + CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+LDABCD*MU), LDABCD, E, + $ LDE ) + END IF +C + NFZ = NU +C +C Set right Kronecker indices (column indices). +C + DO 10 I = 1, NKROR + IWORK(I) = KRONR(I) + 10 CONTINUE +C + J = 0 + DO 30 I = 1, NKROR + DO 20 II = J + 1, J + IWORK(I) + KRONR(II) = I - 1 + 20 CONTINUE + J = J + IWORK(I) + 30 CONTINUE +C + NKROR = J +C +C Set left Kronecker indices (row indices). +C + DO 40 I = 1, NKROL + IWORK(I) = KRONL(I) + 40 CONTINUE +C + J = 0 + DO 60 I = 1, NKROL + DO 50 II = J + 1, J + IWORK(I) + KRONL(II) = I - 1 + 50 CONTINUE + J = J + IWORK(I) + 60 CONTINUE +C + NKROL = J +C +C Determine the number of simple infinite blocks +C as the difference between the number of infinite blocks +C of order greater than one and the order of Dr. +C + NINFE = 0 + DO 70 I = 1, DINFZ + NINFE = NINFE + INFZ(I) + 70 CONTINUE + NINFE = NSINFE - NINFE + DO 80 I = 1, NINFE + INFE(I) = 1 + 80 CONTINUE +C +C Set the structure of infinite eigenvalues. +C + DO 100 I = 1, DINFZ + DO 90 II = NINFE + 1, NINFE + INFZ(I) + INFE(II) = I + 1 + 90 CONTINUE + NINFE = NINFE + INFZ(I) + 100 CONTINUE +C + IWORK(1) = NSINFE + DWORK(1) = WRKOPT + RETURN +C *** Last line of AG08BD *** + END diff --git a/mex/sources/libslicot/AG08BY.f b/mex/sources/libslicot/AG08BY.f new file mode 100644 index 000000000..7e980bf87 --- /dev/null +++ b/mex/sources/libslicot/AG08BY.f @@ -0,0 +1,680 @@ + SUBROUTINE AG08BY( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, + $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) descriptor system pencil +C +C S(lambda) = ( B A - lambda*E ) +C ( D C ) +C +C with E nonsingular and upper triangular a +C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil +C +C ( Br Ar-lambda*Er ) +C Sr(lambda) = ( ) +C ( Dr Cr ) +C +C having the same finite Smith zeros as the pencil +C S(lambda) but with Dr, a PR-by-M full row rank +C left upper trapezoidal matrix, and Er, an NR-by-NR +C upper triangular nonsingular matrix. +C +C ARGUMENTS +C +C Mode Parameters +C +C FIRST LOGICAL +C Specifies if AG08BY is called first time or it is called +C for an already reduced system, with D full column rank +C with the last M rows in upper triangular form: +C FIRST = .TRUE., first time called; +C FIRST = .FALSE., not first time called. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of matrix B, the number of columns of +C matrix C and the order of square matrices A and E. +C N >= 0. +C +C M (input) INTEGER +C The number of columns of matrices B and D. M >= 0. +C M <= P if FIRST = .FALSE. . +C +C P (input) INTEGER +C The number of rows of matrices C and D. P >= 0. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) DOUBLE PRECISION array, dimension +C (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound matrix +C ( B A ) , +C ( D C ) +C where A is an N-by-N matrix, B is an N-by-M matrix, +C C is a P-by-N matrix and D is a P-by-M matrix. +C If FIRST = .FALSE., then D must be a full column +C rank matrix with the last M rows in upper triangular form. +C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD +C contains the reduced compound matrix +C ( Br Ar ) , +C ( Dr Cr ) +C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, +C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank +C left upper trapezoidal matrix with the first PR columns +C in upper triangular form. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular nonsingular matrix E. +C On exit, the leading NR-by-NR part contains the reduced +C upper triangular nonsingular matrix Er. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C NR (output) INTEGER +C The order of the reduced matrices Ar and Er; also the +C number of rows of the reduced matrix Br and the number +C of columns of the reduced matrix Cr. +C If Dr is invertible, NR is also the number of finite +C Smith zeros. +C +C PR (output) INTEGER +C The rank of the resulting matrix Dr; also the number of +C rows of reduced matrices Cr and Dr. +C +C NINFZ (output) INTEGER +C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . +C +C DINFZ (output) INTEGER +C The maximal multiplicity of infinite zeros. +C DINFZ = 0 if FIRST = .FALSE. . +C +C NKRONL (output) INTEGER +C The maximal dimension of left elementary Kronecker blocks. +C +C INFZ (output) INTEGER array, dimension (N) +C INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,DINFZ. +C INFZ is not referenced if FIRST = .FALSE. . +C +C KRONL (output) INTEGER array, dimension (N+1) +C KRONL(i) contains the number of left elementary Kronecker +C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used +C instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C If FIRST = .FALSE., IWORK is not referenced. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1, if P = 0; otherwise +C LDWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 5*P ), +C if FIRST = .TRUE.; +C LDWORK >= MAX( 1, N+M-1, 5*P ), if FIRST = .FALSE. . +C The second term is not needed if M = 0. +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithm of [1]. +C +C REFERENCES +C +C [1] P. Misra, P. Van Dooren and A. Varga. +C Computation of structural invariants of generalized +C state-space systems. +C Automatica, 30, pp. 1921-1936, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( (P+N)*(M+N)*N ) floating point operations. +C +C FURTHER COMMENTS +C +C The number of infinite zeros is computed as +C +C DINFZ +C NINFZ = Sum (INFZ(i)*i) . +C i=1 +C Note that each infinite zero of multiplicity k corresponds to +C an infinite eigenvalue of multiplicity k+1. +C The multiplicities of the infinite eigenvalues can be determined +C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: +C +C DINFZ +C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; +C i=1 +C +C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, +C for i = 1, ..., DINFZ. +C +C The left Kronecker indices are: +C +C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] +C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C May 1999. Based on the RASP routine SRISEP. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999, +C Jan. 2009, Apr. 2009. +C A. Varga, DLR Oberpfaffenhofen, March 2002. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, orthogonal transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ONE, P05, ZERO + PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DINFZ, INFO, LDABCD, LDE, LDWORK, M, N, NINFZ, + $ NKRONL, NR, P, PR + DOUBLE PRECISION SVLMAX, TOL + LOGICAL FIRST +C .. Array Arguments .. + INTEGER INFZ( * ), IWORK(*), KRONL( * ) + DOUBLE PRECISION ABCD( LDABCD, * ), DWORK( * ), E( LDE, * ) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, + $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, + $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NB, NBLCKS, + $ PN, RANK, RO, RO1, SIGMA, TAUI, WRKOPT + DOUBLE PRECISION C, C1, C2, RCOND, S, S1, S2, SMAX, SMAXPR, + $ SMIN, SMINPR, T, TT +C .. Local Arrays .. + DOUBLE PRECISION DUM(1), SVAL(3) +C .. External Functions .. + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DLAMCH, DNRM2, IDAMAX, ILAENV +C .. External Subroutines .. + EXTERNAL DCOPY, DLAIC1, DLAPMT, DLARFG, DLARTG, DLASET, + $ DLATZM, DORMQR, DROT, DSWAP, MB03OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C +C Test the input parameters. +C + LQUERY = ( LDWORK.EQ.-1 ) + INFO = 0 + PN = P + N + MN = M + N + MPM = MIN( P, M ) + IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -5 + ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -17 + ELSE + WRKOPT = MAX( 1, 5*P ) + IF( P.GT.0 ) THEN + IF( M.GT.0 ) THEN + WRKOPT = MAX( WRKOPT, MN-1 ) + IF( FIRST ) THEN + WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) + IF( LQUERY ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', P, N, + $ MPM, -1 ) ) + WRKOPT = MAX( WRKOPT, MPM + MAX( 1, N )*NB ) + END IF + END IF + END IF + END IF + IF( LDWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN + INFO = -20 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AG08BY', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Initialize output variables. +C + PR = P + NR = N + DINFZ = 0 + NINFZ = 0 + NKRONL = 0 +C +C Quick return if possible. +C + IF( P.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF + IF( N.EQ.0 .AND. M.EQ.0 ) THEN + PR = 0 + NKRONL = 1 + KRONL(1) = P + DWORK(1) = ONE + RETURN + END IF +C + RCOND = TOL + IF( RCOND.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) + END IF +C +C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and +C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. +C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column +C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. +C + IF( FIRST ) THEN + SIGMA = 0 + ELSE + SIGMA = M + END IF + RO = P - SIGMA + MP1 = M + 1 + MUI = 0 + DUM(1) = ZERO +C + ITAU = 1 + JWORK1 = ITAU + MPM + ISMIN = 2*P + 1 + ISMAX = ISMIN + P + JWORK2 = ISMAX + P + NBLCKS = 0 + WRKOPT = 1 +C + 10 IF( PR.EQ.0 ) GO TO 90 +C +C (NR+1,ICOL+1) points to the current position of matrix D. +C + RO1 = RO + MNR = M + NR + IF( M.GT.0 ) THEN +C +C Compress rows of D; first exploit the trapezoidal shape of the +C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; +C compress the first SIGMA columns without column pivoting: +C +C ( x x x x x ) ( x x x x x ) +C ( x x x x x ) ( 0 x x x x ) +C ( x x x x x ) - > ( 0 0 x x x ) +C ( 0 x x x x ) ( 0 0 0 x x ) +C ( 0 0 x x x ) ( 0 0 0 x x ) +C +C where SIGMA = 3 and RO = 2. +C Workspace: need maximum M+N-1. +C + IROW = NR + DO 20 ICOL = 1, SIGMA + IROW = IROW + 1 + CALL DLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, + $ T ) + CALL DLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, T, + $ ABCD(IROW,ICOL+1), ABCD(IROW+1,ICOL+1), + $ LDABCD, DWORK ) + CALL DCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) + 20 CONTINUE + WRKOPT = MAX( WRKOPT, MN - 1 ) +C + IF( FIRST ) THEN +C +C Continue with Householder with column pivoting. +C +C ( x x x x x ) ( x x x x x ) +C ( 0 x x x x ) ( 0 x x x x ) +C ( 0 0 x x x ) - > ( 0 0 x x x ) +C ( 0 0 0 x x ) ( 0 0 0 x x ) +C ( 0 0 0 x x ) ( 0 0 0 0 0 ) +C +C Real workspace: need maximum min(P,M)+3*M-1; +C Integer workspace: need maximum M. +C + IROW = MIN( NR+SIGMA+1, PN ) + ICOL = MIN( SIGMA+1, M ) + CALL MB03OY( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, + $ RCOND, SVLMAX, RANK, SVAL, IWORK, DWORK(ITAU), + $ DWORK(JWORK1), INFO ) + WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) +C +C Apply the column permutations to B and part of D. +C + CALL DLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), + $ LDABCD, IWORK ) +C + IF( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C Workspace: need maximum min(P,M) + N; +C prefer maximum min(P,M) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', RO1, NR, RANK, + $ ABCD(IROW,ICOL), LDABCD, DWORK(ITAU), + $ ABCD(IROW,MP1), LDABCD, DWORK(JWORK1), + $ LDWORK-JWORK1+1, INFO ) + WRKOPT = MAX( WRKOPT, JWORK1 + INT( DWORK(JWORK1) ) - 1 ) + CALL DLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), ZERO, + $ ZERO, ABCD(MIN( IROW+1, PN ),ICOL), LDABCD ) + RO1 = RO1 - RANK + END IF + END IF +C +C Terminate if Dr has maximal row rank. +C + IF( RO1.EQ.0 ) GO TO 90 +C + END IF +C +C Update SIGMA. +C + SIGMA = PR - RO1 +C + NBLCKS = NBLCKS + 1 + TAUI = RO1 +C +C Compress the columns of current C to separate a TAUI-by-MUI +C full column rank block. +C + IF( NR.EQ.0 ) THEN +C +C Finish for zero state dimension. +C + PR = SIGMA + RANK = 0 + ELSE +C +C Perform RQ-decomposition with row pivoting on the current C +C while keeping E upper triangular. +C The current C is the TAUI-by-NR matrix delimited by rows +C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. +C The rank of current C is computed in MUI. +C Workspace: need maximum 5*P. +C + IRC = NR + SIGMA + N1 = NR + IF( TAUI.GT.1 ) THEN +C +C Compute norms. +C + DO 30 I = 1, TAUI + DWORK(I) = DNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) + DWORK(P+I) = DWORK(I) + 30 CONTINUE + END IF +C + RANK = 0 + MNTAU = MIN( TAUI, NR ) +C +C ICOL and IROW will point to the current pivot position in C. +C + ILAST = NR + PR + JLAST = M + NR + IROW = ILAST + ICOL = JLAST + I = TAUI + 40 IF( RANK.LT.MNTAU ) THEN + MN1 = M + N1 +C +C Pivot if necessary. +C + IF( I.NE.1 ) THEN + J = IDAMAX( I, DWORK, 1 ) + IF( J.NE.I ) THEN + DWORK(J) = DWORK(I) + DWORK(P+J) = DWORK(P+I) + CALL DSWAP( N1, ABCD(IROW,MP1), LDABCD, + $ ABCD(IRC+J,MP1), LDABCD ) + END IF + END IF +C +C Zero elements left to ABCD(IROW,ICOL). +C + DO 50 K = 1, N1-1 + J = M + K +C +C Rotate columns J, J+1 to zero ABCD(IROW,J). +C + T = ABCD(IROW,J+1) + CALL DLARTG( T, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) + ABCD(IROW,J) = ZERO + CALL DROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) + CALL DROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) +C +C Rotate rows K, K+1 to zero E(K+1,K). +C + T = E(K,K) + CALL DLARTG( T, E(K+1,K), C, S, E(K,K) ) + E(K+1,K) = ZERO + CALL DROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) + CALL DROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, + $ C, S ) + 50 CONTINUE +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( ABCD(ILAST,JLAST) ) + IF ( SMAX.EQ.ZERO ) GO TO 80 + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, + $ DWORK(JWORK2), 1 ) + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, + $ DWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, + $ C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, + $ DWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, + $ C2 ) + WRKOPT = MAX( WRKOPT, 5*P ) + END IF +C +C Check the rank; finish the loop if rank loss occurs. +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Finish the loop if last row. +C + IF( N1.EQ.0 ) THEN + RANK = RANK + 1 + GO TO 80 + END IF +C + IF( N1.GT.1 ) THEN +C +C Update norms. +C + IF( I-1.GT.1 ) THEN + DO 60 J = 1, I - 1 + IF( DWORK(J).NE.ZERO ) THEN + T = ONE - ( ABS( ABCD(IRC+J,ICOL) ) + $ /DWORK(J) )**2 + T = MAX( T, ZERO ) + TT = ONE + + $ P05*T*( DWORK(J)/DWORK(P+J) )**2 + IF( TT.NE.ONE ) THEN + DWORK(J) = DWORK(J)*SQRT( T ) + ELSE + DWORK(J) = DNRM2( N1-1, + $ ABCD(IRC+J,MP1), LDABCD ) + DWORK(P+J) = DWORK(J) + END IF + END IF + 60 CONTINUE + END IF + END IF +C + DO 70 J = 1, RANK + DWORK( ISMIN+J-1 ) = S1*DWORK( ISMIN+J-1 ) + DWORK( ISMAX+J-1 ) = S2*DWORK( ISMAX+J-1 ) + 70 CONTINUE +C + DWORK( ISMIN+RANK ) = C1 + DWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + ICOL = ICOL - 1 + IROW = IROW - 1 + N1 = N1 - 1 + I = I - 1 + GO TO 40 + END IF + END IF + END IF + END IF + END IF +C + 80 CONTINUE + MUI = RANK + NR = NR - MUI + PR = SIGMA + MUI +C +C Set number of left Kronecker blocks of order (i-1)-by-i. +C + KRONL(NBLCKS) = TAUI - MUI +C +C Set number of infinite divisors of order i-1. +C + IF( FIRST .AND. NBLCKS.GT.1 ) + $ INFZ(NBLCKS-1) = MUIM1 - TAUI + MUIM1 = MUI + RO = MUI +C +C Continue reduction if rank of current C is positive. +C + IF( MUI.GT.0 ) + $ GO TO 10 +C +C Determine the maximal degree of infinite zeros and +C the number of infinite zeros. +C + 90 CONTINUE + IF( FIRST ) THEN + IF( MUI.EQ.0 ) THEN + DINFZ = MAX( 0, NBLCKS - 1 ) + ELSE + DINFZ = NBLCKS + INFZ(NBLCKS) = MUI + END IF + K = DINFZ + DO 100 I = K, 1, -1 + IF( INFZ(I).NE.0 ) GO TO 110 + DINFZ = DINFZ - 1 + 100 CONTINUE + 110 CONTINUE + DO 120 I = 1, DINFZ + NINFZ = NINFZ + INFZ(I)*I + 120 CONTINUE + END IF +C +C Determine the maximal order of left elementary Kronecker blocks. +C + NKRONL = NBLCKS + DO 130 I = NBLCKS, 1, -1 + IF( KRONL(I).NE.0 ) GO TO 140 + NKRONL = NKRONL - 1 + 130 CONTINUE + 140 CONTINUE +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of AG08BY *** + END diff --git a/mex/sources/libslicot/AG08BZ.f b/mex/sources/libslicot/AG08BZ.f new file mode 100644 index 000000000..6292b0554 --- /dev/null +++ b/mex/sources/libslicot/AG08BZ.f @@ -0,0 +1,641 @@ + SUBROUTINE AG08BZ( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR, + $ NINFE, NKROL, INFZ, KRONR, INFE, KRONL, + $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the system pencil +C +C ( A-lambda*E B ) +C S(lambda) = ( ) +C ( C D ) +C +C a regular pencil Af-lambda*Ef which has the finite Smith zeros of +C S(lambda) as generalized eigenvalues. The routine also computes +C the orders of the infinite Smith zeros and determines the singular +C and infinite Kronecker structure of system pencil, i.e., the right +C and left Kronecker indices, and the multiplicities of infinite +C eigenvalues. +C +C ARGUMENTS +C +C Mode Parameters +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the system +C matrix as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A of the system. +C On exit, the leading NFZ-by-NFZ part of this array +C contains the matrix Af of the reduced pencil. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) COMPLEX*16 array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E of the system. +C On exit, the leading NFZ-by-NFZ part of this array +C contains the matrix Ef of the reduced pencil. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B of the system. +C On exit, this matrix does not contain useful information. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0; +C LDB >= 1 if M = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C of the system. +C On exit, this matrix does not contain useful information. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) COMPLEX*16 array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct transmission matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NFZ (output) INTEGER +C The number of finite zeros. +C +C NRANK (output) INTEGER +C The normal rank of the system pencil. +C +C NIZ (output) INTEGER +C The number of infinite zeros. +C +C DINFZ (output) INTEGER +C The maximal multiplicity of infinite Smith zeros. +C +C NKROR (output) INTEGER +C The number of right Kronecker indices. +C +C NINFE (output) INTEGER +C The number of elementary infinite blocks. +C +C NKROL (output) INTEGER +C The number of left Kronecker indices. +C +C INFZ (output) INTEGER array, dimension (N+1) +C The leading DINFZ elements of INFZ contain information +C on the infinite elementary divisors as follows: +C the system has INFZ(i) infinite elementary divisors of +C degree i in the Smith form, where i = 1,2,...,DINFZ. +C +C KRONR (output) INTEGER array, dimension (N+M+1) +C The leading NKROR elements of this array contain the +C right Kronecker (column) indices. +C +C INFE (output) INTEGER array, dimension (1+MIN(L+P,N+M)) +C The leading NINFE elements of INFE contain the +C multiplicities of infinite eigenvalues. +C +C KRONL (output) INTEGER array, dimension (L+P+1) +C The leading NKROL elements of this array contain the +C left Kronecker (row) indices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL <= 0, then default tolerances are +C used instead, as follows: TOLDEF = L*N*EPS in TG01FZ +C (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS +C in the rest, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension N+max(1,M) +C On output, IWORK(1) contains the normal rank of the +C transfer function matrix. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C LDWORK >= max(4*(L+N), 2*max(L+P,M+N))), if EQUIL = 'S', +C LDWORK >= 2*max(L+P,M+N)), if EQUIL = 'N'. +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= max( max(L+P,M+N)*(M+N) + +C max(min(L+P,M+N) + max(min(L,N),3*(M+N)-1), +C 3*(L+P), 1)) +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine extracts from the system matrix of a descriptor +C system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which +C has the finite zeros of the system as generalized eigenvalues. +C The procedure has the following main computational steps: +C +C (a) construct the (L+P)-by-(N+M) system pencil +C +C S(lambda) = ( B A )-lambda*( 0 E ); +C ( D C ) ( 0 0 ) +C +C (b) reduce S(lambda) to S1(lambda) with the same finite +C zeros and right Kronecker structure but with E +C upper triangular and nonsingular; +C +C (c) reduce S1(lambda) to S2(lambda) with the same finite +C zeros and right Kronecker structure but with D of +C full row rank; +C +C (d) reduce S2(lambda) to S3(lambda) with the same finite zeros +C and with D square invertible; +C +C (e) perform a unitary transformation on the columns of +C +C S3(lambda) = (A-lambda*E B) in order to reduce it to +C ( C D) +C +C (Af-lambda*Ef X), with Y and Ef square invertible; +C ( 0 Y) +C +C (f) compute the right and left Kronecker indices of the system +C matrix, which together with the multiplicities of the +C finite and infinite eigenvalues constitute the +C complete set of structural invariants under strict +C equivalence transformations of a linear system. +C +C REFERENCES +C +C [1] P. Misra, P. Van Dooren and A. Varga. +C Computation of structural invariants of generalized +C state-space systems. +C Automatica, 30, pp. 1921-1936, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable (see [1]). +C +C FURTHER COMMENTS +C +C In order to compute the finite Smith zeros of the system +C explicitly, a call to this routine may be followed by a +C call to the LAPACK Library routines ZGEGV or ZGGEV. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C May 1999. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, unitary transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + CHARACTER EQUIL + INTEGER DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LZWORK, + $ M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*) + DOUBLE PRECISION DWORK(*) + COMPLEX*16 A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ E(LDE,*), ZWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LQUERY + INTEGER I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD, + $ LABCD2, LDABCD, LZW, MM, MU, N2, NB, NN, NSINFE, + $ NU, NUMU, PP, WRKOPT + DOUBLE PRECISION SVLMAX, TOLER +C .. Local Arrays .. + COMPLEX*16 DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL AG8BYZ, MA02BZ, MA02CZ, TB01XZ, TG01AZ, TG01FZ, + $ XERBLA, ZLACPY, ZLASET, ZTZRZF, ZUNMRZ +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LDABCD = MAX( L+P, N+M ) + LABCD2 = LDABCD*( N+M ) + LEQUIL = LSAME( EQUIL, 'S' ) + LQUERY = ( LZWORK.EQ.-1 ) +C +C Test the input scalar arguments. +C + IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -27 + ELSE + I0 = MIN( L+P, M+N ) + I1 = MIN( L, N ) + II = MIN( M, P ) + LZW = MAX( 1, LABCD2 + MAX( I0 + MAX( I1, 3*( M+N ) - 1 ), + $ 3*( L+P ) ) ) + IF( LQUERY ) THEN + CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, + $ LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, + $ IWORK, DWORK, ZWORK, -1, INFO ) + WRKOPT = MAX( LZW, INT( ZWORK(1) ) ) + SVLMAX = ZERO + CALL AG8BYZ( .TRUE., I1, M+N, P+L, SVLMAX, ZWORK, LDABCD+I1, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOL, IWORK, DWORK, ZWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) + CALL AG8BYZ( .FALSE., I1, II, M+N, SVLMAX, ZWORK, LDABCD+I1, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOL, IWORK, DWORK, ZWORK, -1, INFO ) + WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) ) + NB = ILAENV( 1, 'ZGERQF', ' ', II, I1+II, -1, -1 ) + WRKOPT = MAX( WRKOPT, LABCD2 + II + II*NB ) + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', I1, I1+II, II, + $ -1 ) ) + WRKOPT = MAX( WRKOPT, LABCD2 + II + I1*NB ) + ELSE IF( LZWORK.LT.LZW ) THEN + INFO = -31 + END IF + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'AG08BZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C + NIZ = 0 + NKROL = 0 + NKROR = 0 +C +C Quick return if possible. +C + IF( MAX( L, N, M, P ).EQ.0 ) THEN + NFZ = 0 + DINFZ = 0 + NINFE = 0 + NRANK = 0 + IWORK(1) = 0 + ZWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "CWorkspace:", "RWorkspace:" +C and "IWorkspace:" describe the minimal amount of complex, real and +C integer workspace, respectively, needed at that point in the code, +C as well as the preferred amount for good performance.) +C + WRKOPT = 1 + KABCD = 1 + JWORK = KABCD + LABCD2 +C +C If required, balance the system pencil. +C RWorkspace: need 4*(L+N). +C + IF( LEQUIL ) THEN + CALL TG01AZ( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, + $ C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO ) + END IF + SVLMAX = ZLANGE( 'Frobenius', L, N, E, LDE, DWORK ) +C +C Reduce the system matrix to QR form, +C +C ( A11-lambda*E11 A12 B1 ) +C ( A21 A22 B2 ) , +C ( C1 C2 D ) +C +C with E11 invertible and upper triangular. +C IWorkspace: need N. +C RWorkspace: need 2*N. +C CWorkspace: need max( 1, N+P, min(L,N)+max(3*N-1,M,L) ); +C prefer larger. +C + CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK, + $ ZWORK, LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) +C +C Construct the system pencil +C +C MM NN +C ( B1 A12 A11-lambda*E11 ) NN +C S1(lambda) = ( B2 A22 A21 ) L-NN +C ( D C2 C1 ) P +C +C of dimension (L+P)-by-(M+N). +C CWorkspace: need LABCD2 = max( L+P, N+M )*( N+M ). +C + N2 = N - NN + MM = M + N2 + PP = P + ( L - NN ) + CALL ZLACPY( 'Full', L, M, B, LDB, ZWORK(KABCD), LDABCD ) + CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(KABCD+L), LDABCD ) + CALL ZLACPY( 'Full', L, N2, A(1,NN+1), LDA, + $ ZWORK(KABCD+LDABCD*M), LDABCD ) + CALL ZLACPY( 'Full', P, N2, C(1,NN+1), LDC, + $ ZWORK(KABCD+LDABCD*M+L), LDABCD ) + CALL ZLACPY( 'Full', L, NN, A, LDA, + $ ZWORK(KABCD+LDABCD*MM), LDABCD ) + CALL ZLACPY( 'Full', P, NN, C, LDC, + $ ZWORK(KABCD+LDABCD*MM+L), LDABCD ) +C +C If required, set tolerance. +C + TOLER = TOL + IF( TOLER.LE.ZERO ) THEN + TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' ) + END IF + SVLMAX = MAX( SVLMAX, + $ ZLANGE( 'Frobenius', NN+PP, NN+MM, ZWORK(KABCD), + $ LDABCD, DWORK ) ) +C +C Extract the reduced pencil S2(lambda) +C +C ( Bc Ac-lambda*Ec ) +C ( Dc Cc ) +C +C having the same finite Smith zeros as the system pencil +C S(lambda) but with Dc, a MU-by-MM full row rank +C left upper trapezoidal matrix, and Ec, an NU-by-NU +C upper triangular nonsingular matrix. +C +C IWorkspace: need MM, MM <= M+N; +C RWorkspace: need 2*max(MM,PP); PP <= P+L; +C CWorkspace: need max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1), +C 3*(P+L), 1 ) + LABCD2; +C prefer larger. +C + CALL AG8BYZ( .TRUE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, + $ E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, + $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, + $ INFO ) +C + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C +C Set the number of simple (nondynamic) infinite eigenvalues +C and the normal rank of the system pencil. +C + NSINFE = MU + NRANK = NN + MU +C +C Pertranspose the system. +C + CALL TB01XZ( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ), + $ ZWORK(KABCD+LDABCD*MM), LDABCD, + $ ZWORK(KABCD), LDABCD, + $ ZWORK(KABCD+LDABCD*MM+NU), LDABCD, + $ ZWORK(KABCD+NU), LDABCD, INFO ) + CALL MA02BZ( 'Right', NU+MM, MM, ZWORK(KABCD), LDABCD ) + CALL MA02BZ( 'Left', MM, NU+MM, ZWORK(KABCD+NU), LDABCD ) + CALL MA02CZ( NU, 0, MAX( 0, NU-1 ), E, LDE ) +C + IF( MU.NE.MM ) THEN + NN = NU + PP = MM + MM = MU + KABCD = KABCD + ( PP - MM )*LDABCD +C +C Extract the reduced pencil S3(lambda), +C +C ( Br Ar-lambda*Er ) , +C ( Dr Cr ) +C +C having the same finite Smith zeros as the pencil S(lambda), +C but with Dr, an MU-by-MU invertible upper triangular matrix, +C and Er, an NU-by-NU upper triangular nonsingular matrix. +C +C IWorkspace: need 0; +C RWorkspace: need 2*(M+N); +C CWorkspace: need max( 1, 3*(M+N) ) + LABCD2. +C prefer larger. +C + CALL AG8BYZ( .FALSE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD, + $ E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR, + $ TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1, + $ INFO ) +C + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF( NU.NE.0 ) THEN +C +C Perform a unitary transformation on the columns of +C ( Br Ar-lambda*Er ) +C ( Dr Cr ) +C in order to reduce it to +C ( * Af-lambda*Ef ) +C ( Y 0 ) +C with Y and Ef square invertible. +C +C Compute Af by reducing ( Br Ar ) to ( * Af ) . +C ( Dr Cr ) ( Y 0 ) +C + NUMU = NU + MU + IPD = KABCD + NU + ITAU = JWORK + JWORK = ITAU + MU +C +C CWorkspace: need LABCD2 + 2*min(M,P); +C prefer LABCD2 + min(M,P) + min(M,P)*NB. +C + CALL ZTZRZF( MU, NUMU, ZWORK(IPD), LDABCD, ZWORK(ITAU), + $ ZWORK(JWORK), LZWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C +C CWorkspace: need LABCD2 + min(M,P) + min(L,N); +C prefer LABCD2 + min(M,P) + min(L,N)*NB. +C + CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, + $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), + $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 ) +C +C Save Af. +C + CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, A, + $ LDA ) +C +C Compute Ef by applying the saved transformations from previous +C reduction to ( 0 Er ) . +C + CALL ZLASET( 'Full', NU, MU, CZERO, CZERO, ZWORK(KABCD), + $ LDABCD ) + CALL ZLACPY( 'Full', NU, NU, E, LDE, ZWORK(KABCD+LDABCD*MU), + $ LDABCD ) +C + CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU, + $ ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD), + $ LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO ) +C +C Save Ef. +C + CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, E, + $ LDE ) + END IF +C + NFZ = NU +C +C Set right Kronecker indices (column indices). +C + DO 10 I = 1, NKROR + IWORK(I) = KRONR(I) + 10 CONTINUE +C + J = 0 + DO 30 I = 1, NKROR + DO 20 II = J + 1, J + IWORK(I) + KRONR(II) = I - 1 + 20 CONTINUE + J = J + IWORK(I) + 30 CONTINUE +C + NKROR = J +C +C Set left Kronecker indices (row indices). +C + DO 40 I = 1, NKROL + IWORK(I) = KRONL(I) + 40 CONTINUE +C + J = 0 + DO 60 I = 1, NKROL + DO 50 II = J + 1, J + IWORK(I) + KRONL(II) = I - 1 + 50 CONTINUE + J = J + IWORK(I) + 60 CONTINUE +C + NKROL = J +C +C Determine the number of simple infinite blocks +C as the difference between the number of infinite blocks +C of order greater than one and the order of Dr. +C + NINFE = 0 + DO 70 I = 1, DINFZ + NINFE = NINFE + INFZ(I) + 70 CONTINUE + NINFE = NSINFE - NINFE + DO 80 I = 1, NINFE + INFE(I) = 1 + 80 CONTINUE +C +C Set the structure of infinite eigenvalues. +C + DO 100 I = 1, DINFZ + DO 90 II = NINFE + 1, NINFE + INFZ(I) + INFE(II) = I + 1 + 90 CONTINUE + NINFE = NINFE + INFZ(I) + 100 CONTINUE +C + IWORK(1) = NSINFE + ZWORK(1) = WRKOPT + RETURN +C *** Last line of AG08BZ *** + END diff --git a/mex/sources/libslicot/AG8BYZ.f b/mex/sources/libslicot/AG8BYZ.f new file mode 100644 index 000000000..c2dc7d5e4 --- /dev/null +++ b/mex/sources/libslicot/AG8BYZ.f @@ -0,0 +1,692 @@ + SUBROUTINE AG8BYZ( FIRST, N, M, P, SVLMAX, ABCD, LDABCD, E, LDE, + $ NR, PR, NINFZ, DINFZ, NKRONL, INFZ, KRONL, + $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To extract from the (N+P)-by-(M+N) descriptor system pencil +C +C S(lambda) = ( B A - lambda*E ) +C ( D C ) +C +C with E nonsingular and upper triangular a +C (NR+PR)-by-(M+NR) "reduced" descriptor system pencil +C +C ( Br Ar-lambda*Er ) +C Sr(lambda) = ( ) +C ( Dr Cr ) +C +C having the same finite Smith zeros as the pencil +C S(lambda) but with Dr, a PR-by-M full row rank +C left upper trapezoidal matrix, and Er, an NR-by-NR +C upper triangular nonsingular matrix. +C +C ARGUMENTS +C +C Mode Parameters +C +C FIRST LOGICAL +C Specifies if AG8BYZ is called first time or it is called +C for an already reduced system, with D full column rank +C with the last M rows in upper triangular form: +C FIRST = .TRUE., first time called; +C FIRST = .FALSE., not first time called. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of matrix B, the number of columns of +C matrix C and the order of square matrices A and E. +C N >= 0. +C +C M (input) INTEGER +C The number of columns of matrices B and D. M >= 0. +C M <= P if FIRST = .FALSE. . +C +C P (input) INTEGER +C The number of rows of matrices C and D. P >= 0. +C +C SVLMAX (input) DOUBLE PRECISION +C During each reduction step, the rank-revealing QR +C factorization of a matrix stops when the estimated minimum +C singular value is smaller than TOL * MAX(SVLMAX,EMSV), +C where EMSV is the estimated maximum singular value. +C SVLMAX >= 0. +C +C ABCD (input/output) COMPLEX*16 array, dimension (LDABCD,M+N) +C On entry, the leading (N+P)-by-(M+N) part of this array +C must contain the compound matrix +C ( B A ) , +C ( D C ) +C where A is an N-by-N matrix, B is an N-by-M matrix, +C C is a P-by-N matrix and D is a P-by-M matrix. +C If FIRST = .FALSE., then D must be a full column +C rank matrix with the last M rows in upper triangular form. +C On exit, the leading (NR+PR)-by-(M+NR) part of ABCD +C contains the reduced compound matrix +C ( Br Ar ) , +C ( Dr Cr ) +C where Ar is an NR-by-NR matrix, Br is an NR-by-M matrix, +C Cr is a PR-by-NR matrix, Dr is a PR-by-M full row rank +C left upper trapezoidal matrix with the first PR columns +C in upper triangular form. +C +C LDABCD INTEGER +C The leading dimension of array ABCD. +C LDABCD >= MAX(1,N+P). +C +C E (input/output) COMPLEX*16 array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular nonsingular matrix E. +C On exit, the leading NR-by-NR part contains the reduced +C upper triangular nonsingular matrix Er. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C NR (output) INTEGER +C The order of the reduced matrices Ar and Er; also the +C number of rows of the reduced matrix Br and the number +C of columns of the reduced matrix Cr. +C If Dr is invertible, NR is also the number of finite +C Smith zeros. +C +C PR (output) INTEGER +C The rank of the resulting matrix Dr; also the number of +C rows of reduced matrices Cr and Dr. +C +C NINFZ (output) INTEGER +C Number of infinite zeros. NINFZ = 0 if FIRST = .FALSE. . +C +C DINFZ (output) INTEGER +C The maximal multiplicity of infinite zeros. +C DINFZ = 0 if FIRST = .FALSE. . +C +C NKRONL (output) INTEGER +C The maximal dimension of left elementary Kronecker blocks. +C +C INFZ (output) INTEGER array, dimension (N) +C INFZ(i) contains the number of infinite zeros of +C degree i, where i = 1,2,...,DINFZ. +C INFZ is not referenced if FIRST = .FALSE. . +C +C KRONL (output) INTEGER array, dimension (N+1) +C KRONL(i) contains the number of left elementary Kronecker +C blocks of dimension i-by-(i-1), where i = 1,2,...,NKRONL. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used in rank decisions to determine the +C effective rank, which is defined as the order of the +C largest leading (or trailing) triangular submatrix in the +C QR (or RQ) factorization with column (or row) pivoting +C whose estimated condition number is less than 1/TOL. +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance TOLDEF = (N+P)*(N+M)*EPS, is used +C instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). +C NOTE that when SVLMAX > 0, the estimated ranks could be +C less than those defined above (see SVLMAX). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C If FIRST = .FALSE., IWORK is not referenced. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C LDWORK >= 2*MAX(M,P), if FIRST = .TRUE.; +C LDWORK >= 2*P, if FIRST = .FALSE. . +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= 1, if P = 0; otherwise +C LZWORK >= MAX( 1, N+M-1, MIN(P,M) + MAX(3*M-1,N), 3*P ), +C if FIRST = .TRUE.; +C LZWORK >= MAX( 1, N+M-1, 3*P ), if FIRST = .FALSE. . +C The second term is not needed if M = 0. +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithm of [1]. +C +C REFERENCES +C +C [1] P. Misra, P. Van Dooren and A. Varga. +C Computation of structural invariants of generalized +C state-space systems. +C Automatica, 30, pp. 1921-1936, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( (P+N)*(M+N)*N ) floating point operations. +C +C FURTHER COMMENTS +C +C The number of infinite zeros is computed as +C +C DINFZ +C NINFZ = Sum (INFZ(i)*i) . +C i=1 +C Note that each infinite zero of multiplicity k corresponds to +C an infinite eigenvalue of multiplicity k+1. +C The multiplicities of the infinite eigenvalues can be determined +C from PR, DINFZ and INFZ(i), i = 1, ..., DINFZ, as follows: +C +C DINFZ +C - there are PR - Sum (INFZ(i)) simple infinite eigenvalues; +C i=1 +C +C - there are INFZ(i) infinite eigenvalues with multiplicity i+1, +C for i = 1, ..., DINFZ. +C +C The left Kronecker indices are: +C +C [ 0 0 ... 0 | 1 1 ... 1 | .... | NKRONL ... NKRONL ] +C |<- KRONL(1) ->|<- KRONL(2) ->| |<- KRONL(NKRONL) ->| +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C May 1999. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, multivariable +C system, unitary transformation, structural invariant. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ONE, P05, ZERO + PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + $ CZERO = ( 0.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER DINFZ, INFO, LDABCD, LDE, LZWORK, M, N, NINFZ, + $ NKRONL, NR, P, PR + DOUBLE PRECISION SVLMAX, TOL + LOGICAL FIRST +C .. Array Arguments .. + INTEGER INFZ( * ), IWORK(*), KRONL( * ) + DOUBLE PRECISION DWORK( * ) + COMPLEX*16 ABCD( LDABCD, * ), E( LDE, * ), ZWORK( * ) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, ICOL, ILAST, IRC, IROW, ISMAX, ISMIN, ITAU, + $ J, JLAST, JWORK1, JWORK2, K, MN, MN1, MNR, + $ MNTAU, MP1, MPM, MUI, MUIM1, N1, NB, NBLCKS, + $ PN, RANK, RO, RO1, SIGMA, TAUI, WRKOPT + DOUBLE PRECISION C, RCOND, SMAX, SMAXPR, SMIN, SMINPR, T, TT + COMPLEX*16 C1, C2, S, S1, S2, TC +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) + COMPLEX*16 DUM(1) +C .. External Functions .. + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DLAMCH, DZNRM2, IDAMAX, ILAENV +C .. External Subroutines .. + EXTERNAL MB3OYZ, XERBLA, ZCOPY, ZLAIC1, ZLAPMT, ZLARFG, + $ ZLARTG, ZLASET, ZLATZM, ZROT, ZSWAP, ZUNMQR +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C +C Test the input parameters. +C + LQUERY = ( LZWORK.EQ.-1 ) + INFO = 0 + PN = P + N + MN = M + N + MPM = MIN( P, M ) + IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 .OR. ( .NOT.FIRST .AND. M.GT.P ) ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -5 + ELSE IF( LDABCD.LT.MAX( 1, PN ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -17 + ELSE + WRKOPT = MAX( 1, 3*P ) + IF( P.GT.0 ) THEN + IF( M.GT.0 ) THEN + WRKOPT = MAX( WRKOPT, MN-1 ) + IF( FIRST ) THEN + WRKOPT = MAX( WRKOPT, MPM + MAX( 3*M-1, N ) ) + IF( LQUERY ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', P, N, + $ MPM, -1 ) ) + WRKOPT = MAX( WRKOPT, MPM + MAX( 1, N )*NB ) + END IF + END IF + END IF + END IF + IF( LZWORK.LT.WRKOPT .AND. .NOT.LQUERY ) THEN + INFO = -21 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'AG8BYZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C +C Initialize output variables. +C + PR = P + NR = N + DINFZ = 0 + NINFZ = 0 + NKRONL = 0 +C +C Quick return if possible. +C + IF( P.EQ.0 ) THEN + ZWORK(1) = CONE + RETURN + END IF + IF( N.EQ.0 .AND. M.EQ.0 ) THEN + PR = 0 + NKRONL = 1 + KRONL(1) = P + ZWORK(1) = CONE + RETURN + END IF +C + RCOND = TOL + IF( RCOND.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + RCOND = DBLE( PN*MN )*DLAMCH( 'EPSILON' ) + END IF +C +C The D matrix is (RO+SIGMA)-by-M, where RO = P - SIGMA and +C SIGMA = 0 for FIRST = .TRUE. and SIGMA = M for FIRST = .FALSE.. +C The leading (RO+SIGMA)-by-SIGMA submatrix of D has full column +C rank, with the trailing SIGMA-by-SIGMA submatrix upper triangular. +C + IF( FIRST ) THEN + SIGMA = 0 + ELSE + SIGMA = M + END IF + RO = P - SIGMA + MP1 = M + 1 + MUI = 0 + DUM(1) = CZERO +C + ITAU = 1 + JWORK1 = ITAU + MPM + ISMIN = 1 + ISMAX = ISMIN + P + JWORK2 = ISMAX + P + NBLCKS = 0 + WRKOPT = 1 +C + 10 IF( PR.EQ.0 ) GO TO 90 +C +C (NR+1,ICOL+1) points to the current position of matrix D. +C + RO1 = RO + MNR = M + NR + IF( M.GT.0 ) THEN +C +C Compress rows of D; first exploit the trapezoidal shape of the +C (RO+SIGMA)-by-SIGMA matrix in the first SIGMA columns of D; +C compress the first SIGMA columns without column pivoting: +C +C ( x x x x x ) ( x x x x x ) +C ( x x x x x ) ( 0 x x x x ) +C ( x x x x x ) - > ( 0 0 x x x ) +C ( 0 x x x x ) ( 0 0 0 x x ) +C ( 0 0 x x x ) ( 0 0 0 x x ) +C +C where SIGMA = 3 and RO = 2. +C Complex workspace: need maximum M+N-1. +C + IROW = NR + DO 20 ICOL = 1, SIGMA + IROW = IROW + 1 + CALL ZLARFG( RO+1, ABCD(IROW,ICOL), ABCD(IROW+1,ICOL), 1, + $ TC ) + CALL ZLATZM( 'L', RO+1, MNR-ICOL, ABCD(IROW+1,ICOL), 1, + $ DCONJG( TC ), ABCD(IROW,ICOL+1), + $ ABCD(IROW+1,ICOL+1), LDABCD, ZWORK ) + CALL ZCOPY( PR-ICOL, DUM, 0, ABCD(IROW+1,ICOL), 1 ) + 20 CONTINUE + WRKOPT = MAX( WRKOPT, MN - 1 ) +C + IF( FIRST ) THEN +C +C Continue with Householder with column pivoting. +C +C ( x x x x x ) ( x x x x x ) +C ( 0 x x x x ) ( 0 x x x x ) +C ( 0 0 x x x ) - > ( 0 0 x x x ) +C ( 0 0 0 x x ) ( 0 0 0 x x ) +C ( 0 0 0 x x ) ( 0 0 0 0 0 ) +C +C Real workspace: need maximum 2*M; +C Complex workspace: need maximum min(P,M)+3*M-1; +C Integer workspace: need maximum M. +C + IROW = MIN( NR+SIGMA+1, PN ) + ICOL = MIN( SIGMA+1, M ) + CALL MB3OYZ( RO1, M-SIGMA, ABCD(IROW,ICOL), LDABCD, + $ RCOND, SVLMAX, RANK, SVAL, IWORK, ZWORK(ITAU), + $ DWORK, ZWORK(JWORK1), INFO ) + WRKOPT = MAX( WRKOPT, JWORK1 + 3*M - 2 ) +C +C Apply the column permutations to B and part of D. +C + CALL ZLAPMT( .TRUE., NR+SIGMA, M-SIGMA, ABCD(1,ICOL), + $ LDABCD, IWORK ) +C + IF( RANK.GT.0 ) THEN +C +C Apply the Householder transformations to the submatrix C. +C Complex workspace: need maximum min(P,M) + N; +C prefer maximum min(P,M) + N*NB. +C + CALL ZUNMQR( 'Left', 'ConjTranspose', RO1, NR, RANK, + $ ABCD(IROW,ICOL), LDABCD, ZWORK(ITAU), + $ ABCD(IROW,MP1), LDABCD, ZWORK(JWORK1), + $ LZWORK-JWORK1+1, INFO ) + WRKOPT = MAX( WRKOPT, JWORK1 + INT( ZWORK(JWORK1) ) - 1 ) + CALL ZLASET( 'Lower', RO1-1, MIN( RO1-1, RANK ), CZERO, + $ CZERO, ABCD(MIN( IROW+1, PN ),ICOL), + $ LDABCD ) + RO1 = RO1 - RANK + END IF + END IF +C +C Terminate if Dr has maximal row rank. +C + IF( RO1.EQ.0 ) GO TO 90 +C + END IF +C +C Update SIGMA. +C + SIGMA = PR - RO1 +C + NBLCKS = NBLCKS + 1 + TAUI = RO1 +C +C Compress the columns of current C to separate a TAUI-by-MUI +C full column rank block. +C + IF( NR.EQ.0 ) THEN +C +C Finish for zero state dimension. +C + PR = SIGMA + RANK = 0 + ELSE +C +C Perform RQ-decomposition with row pivoting on the current C +C while keeping E upper triangular. +C The current C is the TAUI-by-NR matrix delimited by rows +C IRC+1 to IRC+TAUI and columns M+1 to M+NR of ABCD. +C The rank of current C is computed in MUI. +C Real workspace: need maximum 2*P; +C Complex workspace: need maximum 3*P. +C + IRC = NR + SIGMA + N1 = NR + IF( TAUI.GT.1 ) THEN +C +C Compute norms. +C + DO 30 I = 1, TAUI + DWORK(I) = DZNRM2( NR, ABCD(IRC+I,MP1), LDABCD ) + DWORK(P+I) = DWORK(I) + 30 CONTINUE + END IF +C + RANK = 0 + MNTAU = MIN( TAUI, NR ) +C +C ICOL and IROW will point to the current pivot position in C. +C + ILAST = NR + PR + JLAST = M + NR + IROW = ILAST + ICOL = JLAST + I = TAUI + 40 IF( RANK.LT.MNTAU ) THEN + MN1 = M + N1 +C +C Pivot if necessary. +C + IF( I.NE.1 ) THEN + J = IDAMAX( I, DWORK, 1 ) + IF( J.NE.I ) THEN + DWORK(J) = DWORK(I) + DWORK(P+J) = DWORK(P+I) + CALL ZSWAP( N1, ABCD(IROW,MP1), LDABCD, + $ ABCD(IRC+J,MP1), LDABCD ) + END IF + END IF +C +C Zero elements left to ABCD(IROW,ICOL). +C + DO 50 K = 1, N1-1 + J = M + K +C +C Rotate columns J, J+1 to zero ABCD(IROW,J). +C + TC = ABCD(IROW,J+1) + CALL ZLARTG( TC, ABCD(IROW,J), C, S, ABCD(IROW,J+1) ) + ABCD(IROW,J) = CZERO + CALL ZROT( IROW-1, ABCD(1,J+1), 1, ABCD(1,J), 1, C, S ) + CALL ZROT( K+1, E(1,K+1), 1, E(1,K), 1, C, S ) +C +C Rotate rows K, K+1 to zero E(K+1,K). +C + TC = E(K,K) + CALL ZLARTG( TC, E(K+1,K), C, S, E(K,K) ) + E(K+1,K) = CZERO + CALL ZROT( N1-K, E(K,K+1), LDE, E(K+1,K+1), LDE, C, S ) + CALL ZROT( MN1, ABCD(K,1), LDABCD, ABCD(K+1,1), LDABCD, + $ C, S ) + 50 CONTINUE +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( ABCD(ILAST,JLAST) ) + IF ( SMAX.EQ.ZERO ) GO TO 80 + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = CONE + C2 = CONE + ELSE +C +C One step of incremental condition estimation. +C Complex workspace: need maximum 3*P. +C + CALL ZCOPY( RANK, ABCD(IROW,ICOL+1), LDABCD, + $ ZWORK(JWORK2), 1 ) + CALL ZLAIC1( IMIN, RANK, ZWORK(ISMIN), SMIN, + $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMINPR, S1, + $ C1 ) + CALL ZLAIC1( IMAX, RANK, ZWORK(ISMAX), SMAX, + $ ZWORK(JWORK2), ABCD(IROW,ICOL), SMAXPR, S2, + $ C2 ) + WRKOPT = MAX( WRKOPT, 3*P ) + END IF +C +C Check the rank; finish the loop if rank loss occurs. +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Finish the loop if last row. +C + IF( N1.EQ.0 ) THEN + RANK = RANK + 1 + GO TO 80 + END IF +C + IF( N1.GT.1 ) THEN +C +C Update norms. +C + IF( I-1.GT.1 ) THEN + DO 60 J = 1, I - 1 + IF( DWORK(J).NE.ZERO ) THEN + T = ONE - ( ABS( ABCD(IRC+J,ICOL) ) + $ /DWORK(J) )**2 + T = MAX( T, ZERO ) + TT = ONE + + $ P05*T*( DWORK(J)/DWORK(P+J) )**2 + IF( TT.NE.ONE ) THEN + DWORK(J) = DWORK(J)*SQRT( T ) + ELSE + DWORK(J) = DZNRM2( N1-1, + $ ABCD(IRC+J,MP1), LDABCD ) + DWORK(P+J) = DWORK(J) + END IF + END IF + 60 CONTINUE + END IF + END IF +C + DO 70 J = 1, RANK + ZWORK(ISMIN+J-1) = S1*ZWORK(ISMIN+J-1) + ZWORK(ISMAX+J-1) = S2*ZWORK(ISMAX+J-1) + 70 CONTINUE +C + ZWORK(ISMIN+RANK) = C1 + ZWORK(ISMAX+RANK) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + ICOL = ICOL - 1 + IROW = IROW - 1 + N1 = N1 - 1 + I = I - 1 + GO TO 40 + END IF + END IF + END IF + END IF + END IF +C + 80 CONTINUE + MUI = RANK + NR = NR - MUI + PR = SIGMA + MUI +C +C Set number of left Kronecker blocks of order (i-1)-by-i. +C + KRONL(NBLCKS) = TAUI - MUI +C +C Set number of infinite divisors of order i-1. +C + IF( FIRST .AND. NBLCKS.GT.1 ) + $ INFZ(NBLCKS-1) = MUIM1 - TAUI + MUIM1 = MUI + RO = MUI +C +C Continue reduction if rank of current C is positive. +C + IF( MUI.GT.0 ) + $ GO TO 10 +C +C Determine the maximal degree of infinite zeros and +C the number of infinite zeros. +C + 90 CONTINUE + IF( FIRST ) THEN + IF( MUI.EQ.0 ) THEN + DINFZ = MAX( 0, NBLCKS - 1 ) + ELSE + DINFZ = NBLCKS + INFZ(NBLCKS) = MUI + END IF + K = DINFZ + DO 100 I = K, 1, -1 + IF( INFZ(I).NE.0 ) GO TO 110 + DINFZ = DINFZ - 1 + 100 CONTINUE + 110 CONTINUE + DO 120 I = 1, DINFZ + NINFZ = NINFZ + INFZ(I)*I + 120 CONTINUE + END IF +C +C Determine the maximal order of left elementary Kronecker blocks. +C + NKRONL = NBLCKS + DO 130 I = NBLCKS, 1, -1 + IF( KRONL(I).NE.0 ) GO TO 140 + NKRONL = NKRONL - 1 + 130 CONTINUE + 140 CONTINUE +C + ZWORK(1) = WRKOPT + RETURN +C *** Last line of AG8BYZ *** + END diff --git a/mex/sources/libslicot/BB01AD.f b/mex/sources/libslicot/BB01AD.f new file mode 100644 index 000000000..8eafe1f32 --- /dev/null +++ b/mex/sources/libslicot/BB01AD.f @@ -0,0 +1,1286 @@ + SUBROUTINE BB01AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, + 1 A, LDA, B, LDB, C, LDC, G, LDG, Q, LDQ, X, LDX, + 2 DWORK, LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate the benchmark examples for the numerical solution of +C continuous-time algebraic Riccati equations (CAREs) of the form +C +C 0 = Q + A'X + XA - XGX +C +C corresponding to the Hamiltonian matrix +C +C ( A G ) +C H = ( T ). +C ( Q -A ) +C +C A,G,Q,X are real N-by-N matrices, Q and G are symmetric and may +C be given in factored form +C +C -1 T T +C (I) G = B R B , (II) Q = C W C . +C +C Here, C is P-by-N, W P-by-P, B N-by-M, and R M-by-M, where W +C and R are symmetric. In linear-quadratic optimal control problems, +C usually W is positive semidefinite and R positive definite. The +C factorized form can be used if the CARE is solved using the +C deflating subspaces of the extended Hamiltonian pencil +C +C ( A 0 B ) ( I 0 0 ) +C ( T ) ( ) +C H - s K = ( Q A 0 ) - s ( 0 -I 0 ) , +C ( T ) ( ) +C ( 0 B R ) ( 0 0 0 ) +C +C where I and 0 denote the identity and zero matrix, respectively, +C of appropriate dimensions. +C +C NOTE: the formulation of the CARE and the related matrix (pencils) +C used here does not include CAREs as they arise in robust +C control (H_infinity optimization). +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER +C This parameter specifies if the default parameters are +C to be used or not. +C = 'N' or 'n' : The parameters given in the input vectors +C xPAR (x = 'D', 'I', 'B', 'CH') are used. +C = 'D' or 'd' : The default parameters for the example +C are used. +C This parameter is not meaningful if NR(1) = 1. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension (2) +C This array determines the example for which CAREX returns +C data. NR(1) is the group of examples. +C NR(1) = 1 : parameter-free problems of fixed size. +C NR(1) = 2 : parameter-dependent problems of fixed size. +C NR(1) = 3 : parameter-free problems of scalable size. +C NR(1) = 4 : parameter-dependent problems of scalable size. +C NR(2) is the number of the example in group NR(1). +C Let NEXi be the number of examples in group i. Currently, +C NEX1 = 6, NEX2 = 9, NEX3 = 2, NEX4 = 4. +C 1 <= NR(1) <= 4; +C 1 <= NR(2) <= NEXi , where i = NR(1). +C +C DPAR (input/output) DOUBLE PRECISION array, dimension (7) +C Double precision parameter vector. For explanation of the +C parameters see [1]. +C DPAR(1) : defines the parameters +C 'delta' for NR(1) = 3, +C 'q' for NR(1).NR(2) = 4.1, +C 'a' for NR(1).NR(2) = 4.2, and +C 'mu' for NR(1).NR(2) = 4.3. +C DPAR(2) : defines parameters +C 'r' for NR(1).NR(2) = 4.1, +C 'b' for NR(1).NR(2) = 4.2, and +C 'delta' for NR(1).NR(2) = 4.3. +C DPAR(3) : defines parameters +C 'c' for NR(1).NR(2) = 4.2 and +C 'kappa' for NR(1).NR(2) = 4.3. +C DPAR(j), j=4,5,6,7: These arguments are only used to +C generate Example 4.2 and define in +C consecutive order the intervals +C ['beta_1', 'beta_2'], +C ['gamma_1', 'gamma_2']. +C NOTE that if DEF = 'D' or 'd', the values of DPAR entries +C on input are ignored and, on output, they are overwritten +C with the default parameters. +C +C IPAR (input/output) INTEGER array, dimension (3) +C On input, IPAR(1) determines the actual state dimension, +C i.e., the order of the matrix A as follows, where +C NO = NR(1).NR(2). +C NR(1) = 1 or 2.1-2.8: IPAR(1) is ignored. +C NO = 2.9 : IPAR(1) = 1 generates the CARE for +C optimal state feedback (default); +C IPAR(1) = 2 generates the Kalman +C filter CARE. +C NO = 3.1 : IPAR(1) is the number of vehicles +C (parameter 'l' in the description +C in [1]). +C NO = 3.2, 4.1 or 4.2: IPAR(1) is the order of the matrix +C A. +C NO = 4.3 or 4.4 : IPAR(1) determines the dimension of +C the second-order system, i.e., the +C order of the stiffness matrix for +C Examples 4.3 and 4.4 (parameter 'l' +C in the description in [1]). +C +C The order of the output matrix A is N = 2*IPAR(1) for +C Example 4.3 and N = 2*IPAR(1)-1 for Examples 3.1 and 4.4. +C NOTE that IPAR(1) is overwritten for Examples 1.1-2.8. For +C the other examples, IPAR(1) is overwritten if the default +C parameters are to be used. +C On output, IPAR(1) contains the order of the matrix A. +C +C On input, IPAR(2) is the number of colums in the matrix B +C in (I) (in control problems, the number of inputs of the +C system). Currently, IPAR(2) is fixed or determined by +C IPAR(1) for all examples and thus is not referenced on +C input. +C On output, IPAR(2) is the number of columns of the +C matrix B from (I). +C NOTE that currently IPAR(2) is overwritten and that +C rank(G) <= IPAR(2). +C +C On input, IPAR(3) is the number of rows in the matrix C +C in (II) (in control problems, the number of outputs of the +C system). Currently, IPAR(3) is fixed or determined by +C IPAR(1) for all examples and thus is not referenced on +C input. +C On output, IPAR(3) contains the number of rows of the +C matrix C in (II). +C NOTE that currently IPAR(3) is overwritten and that +C rank(Q) <= IPAR(3). +C +C BPAR (input) BOOLEAN array, dimension (6) +C This array defines the form of the output of the examples +C and the storage mode of the matrices G and Q. +C BPAR(1) = .TRUE. : G is returned. +C BPAR(1) = .FALSE. : G is returned in factored form, i.e., +C B and R from (I) are returned. +C BPAR(2) = .TRUE. : The matrix returned in array G (i.e., +C G if BPAR(1) = .TRUE. and R if +C BPAR(1) = .FALSE.) is stored as full +C matrix. +C BPAR(2) = .FALSE. : The matrix returned in array G is +C provided in packed storage mode. +C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix +C returned in array G is stored in upper +C packed mode, i.e., the upper triangle +C of a symmetric n-by-n matrix is stored +C by columns, e.g., the matrix entry +C G(i,j) is stored in the array entry +C G(i+j*(j-1)/2) for i <= j. +C Otherwise, this entry is ignored. +C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix +C returned in array G is stored in lower +C packed mode, i.e., the lower triangle +C of a symmetric n-by-n matrix is stored +C by columns, e.g., the matrix entry +C G(i,j) is stored in the array entry +C G(i+(2*n-j)*(j-1)/2) for j <= i. +C Otherwise, this entry is ignored. +C BPAR(4) = .TRUE. : Q is returned. +C BPAR(4) = .FALSE. : Q is returned in factored form, i.e., +C C and W from (II) are returned. +C BPAR(5) = .TRUE. : The matrix returned in array Q (i.e., +C Q if BPAR(4) = .TRUE. and W if +C BPAR(4) = .FALSE.) is stored as full +C matrix. +C BPAR(5) = .FALSE. : The matrix returned in array Q is +C provided in packed storage mode. +C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix +C returned in array Q is stored in upper +C packed mode (see above). +C Otherwise, this entry is ignored. +C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix +C returned in array Q is stored in lower +C packed mode (see above). +C Otherwise, this entry is ignored. +C NOTE that there are no default values for BPAR. If all +C entries are declared to be .TRUE., then matrices G and Q +C are returned in conventional storage mode, i.e., as +C N-by-N arrays where the array element Z(I,J) contains the +C matrix entry Z_{i,j}. +C +C CHPAR (input/output) CHARACTER*255 +C On input, this is the name of a data file supplied by the +C user. +C In the current version, only Example 4.4 allows a +C user-defined data file. This file must contain +C consecutively DOUBLE PRECISION vectors mu, delta, gamma, +C and kappa. The length of these vectors is determined by +C the input value for IPAR(1). +C If on entry, IPAR(1) = L, then mu and delta must each +C contain L DOUBLE PRECISION values, and gamma and kappa +C must each contain L-1 DOUBLE PRECISION values. +C On output, this string contains short information about +C the chosen example. +C +C VEC (output) LOGICAL array, dimension (9) +C Flag vector which displays the availability of the output +C data: +C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and +C are always .TRUE. +C VEC(4) refers to A and is always .TRUE. +C VEC(5) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors B +C and R from (I) are returned. +C VEC(6) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors C +C and W from (II) are returned. +C VEC(7) refers to G and is always .TRUE. +C VEC(8) refers to Q and is always .TRUE. +C VEC(9) refers to X and is .TRUE. if the exact solution +C matrix is available. +C NOTE that VEC(i) = .FALSE. for i = 1 to 9 if on exit +C INFO .NE. 0. +C +C N (output) INTEGER +C The order of the matrices A, X, G if BPAR(1) = .TRUE., and +C Q if BPAR(4) = .TRUE. +C +C M (output) INTEGER +C The number of columns in the matrix B (or the dimension of +C the control input space of the underlying dynamical +C system). +C +C P (output) INTEGER +C The number of rows in the matrix C (or the dimension of +C the output space of the underlying dynamical system). +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C coefficient matrix A of the CARE. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If (BPAR(1) = .FALSE.), then the leading N-by-M part of +C this array contains the matrix B of the factored form (I) +C of G. Otherwise, B is used as workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C If (BPAR(4) = .FALSE.), then the leading P-by-N part of +C this array contains the matrix C of the factored form (II) +C of Q. Otherwise, C is used as workspace. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= P, where P is the number of rows of the matrix C, +C i.e., the output value of IPAR(3). (For all examples, +C P <= N, where N equals the output value of the argument +C IPAR(1), i.e., LDC >= LDA is always safe.) +C +C G (output) DOUBLE PRECISION array, dimension (NG) +C If (BPAR(2) = .TRUE.) then NG = LDG*N. +C If (BPAR(2) = .FALSE.) then NG = N*(N+1)/2. +C If (BPAR(1) = .TRUE.), then array G contains the +C coefficient matrix G of the CARE. +C If (BPAR(1) = .FALSE.), then array G contains the 'control +C weighting matrix' R of G's factored form as in (I). (For +C all examples, M <= N.) The symmetric matrix contained in +C array G is stored according to BPAR(2) and BPAR(3). +C +C LDG INTEGER +C If conventional storage mode is used for G, i.e., +C BPAR(2) = .TRUE., then G is stored like a 2-dimensional +C array with leading dimension LDG. If packed symmetric +C storage mode is used, then LDG is not referenced. +C LDG >= N if BPAR(2) = .TRUE.. +C +C Q (output) DOUBLE PRECISION array, dimension (NQ) +C If (BPAR(5) = .TRUE.) then NQ = LDQ*N. +C If (BPAR(5) = .FALSE.) then NQ = N*(N+1)/2. +C If (BPAR(4) = .TRUE.), then array Q contains the +C coefficient matrix Q of the CARE. +C If (BPAR(4) = .FALSE.), then array Q contains the 'output +C weighting matrix' W of Q's factored form as in (II). +C The symmetric matrix contained in array Q is stored +C according to BPAR(5) and BPAR(6). +C +C LDQ INTEGER +C If conventional storage mode is used for Q, i.e., +C BPAR(5) = .TRUE., then Q is stored like a 2-dimensional +C array with leading dimension LDQ. If packed symmetric +C storage mode is used, then LDQ is not referenced. +C LDQ >= N if BPAR(5) = .TRUE.. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,IPAR(1)) +C If an exact solution is available (NR = 1.1, 1.2, 2.1, +C 2.3-2.6, 3.2), then the leading N-by-N part of this array +C contains the solution matrix X in conventional storage +C mode. Otherwise, X is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= 1, and +C LDX >= N if NR = 1.1, 1.2, 2.1, 2.3-2.6, 3.2. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= N*MAX(4,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0 : successful exit; +C < 0 : if INFO = -i, the i-th argument had an illegal +C value; +C = 1 : data file could not be opened or had wrong format; +C = 2 : division by zero; +C = 3 : G can not be computed as in (I) due to a singular R +C matrix. +C +C REFERENCES +C +C [1] Abels, J. and Benner, P. +C CAREX - A Collection of Benchmark Examples for Continuous-Time +C Algebraic Riccati Equations (Version 2.0). +C SLICOT Working Note 1999-14, November 1999. Available from +C http://www.win.tue.nl/niconet/NIC2/reports.html. +C +C This is an updated and extended version of +C +C [2] Benner, P., Laub, A.J., and Mehrmann, V. +C A Collection of Benchmark Examples for the Numerical Solution +C of Algebraic Riccati Equations I: Continuous-Time Case. +C Technical Report SPC 95_22, Fak. f. Mathematik, +C TU Chemnitz-Zwickau (Germany), October 1995. +C +C NUMERICAL ASPECTS +C +C If the original data as taken from the literature is given via +C matrices G and Q, but factored forms are requested as output, then +C these factors are obtained from Cholesky or LDL' decompositions of +C G and Q, i.e., the output data will be corrupted by roundoff +C errors. +C +C FURTHER COMMENTS +C +C Some benchmark examples read data from the data files provided +C with the collection. +C +C CONTRIBUTOR +C +C Peter Benner (Universitaet Bremen), November 15, 1999. +C +C For questions concerning the collection or for the submission of +C test examples, please send e-mail to benner@math.uni-bremen.de. +C +C REVISIONS +C +C 1999, December 23 (V. Sima). +C +C KEYWORDS +C +C Algebraic Riccati equation, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. +C . # of examples available , # of examples with fixed size. . + INTEGER NEX1, NEX2, NEX3, NEX4, NMAX + PARAMETER ( NMAX = 9, NEX1 = 6, NEX2 = 9, NEX3 = 2, + 1 NEX4 = 4 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + 1 THREE = 3.0D0, FOUR = 4.0D0, + 2 PI = .3141592653589793D1 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDG, LDQ, LDWORK, LDX, M, N, + $ P + CHARACTER DEF +C +C .. Array Arguments .. + INTEGER IPAR(3), NR(2) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), + 1 G(*), Q(*), X(LDX,*) + CHARACTER CHPAR*255 + LOGICAL BPAR(6), VEC(9) +C +C .. Local Scalars .. + INTEGER GDIMM, I, IOS, ISYMM, J, K, L, MSYMM, NSYMM, POS, + 1 PSYMM, QDIMM + DOUBLE PRECISION APPIND, B1, B2, C1, C2, SUM, TEMP, TTEMP +C +C ..Local Arrays .. + INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) + DOUBLE PRECISION PARDEF(4,NMAX) + CHARACTER IDENT*4 + CHARACTER*255 NOTES(4,NMAX) +C +C .. External Functions .. +C . BLAS . + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C . LAPACK . + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL LSAME, DLAPY2 +C +C .. External Subroutines .. +C . BLAS . + EXTERNAL DCOPY, DGEMV, DSCAL, DSPMV, DSPR, DSYMM, DSYRK +C . LAPACK . + EXTERNAL DLASET, DPPTRF, DPPTRI, DPTTRF, DPTTRS, XERBLA +C . SLICOT . + EXTERNAL MA02DD, MA02ED +C +C .. Intrinsic Functions .. + INTRINSIC COS, MAX, MIN, MOD, SQRT +C +C .. Data Statements .. +C . default values for dimensions . + DATA (NEX(I), I = 1, 4) /NEX1, NEX2, NEX3, NEX4/ + DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 30/ + DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 2, 2, 3, 4, 4, 55/ + DATA (NDEF(3,I), I = 1, NEX3) /20, 64/ + DATA (NDEF(4,I), I = 1, NEX4) /21, 100, 30, 211/ + DATA (MDEF(1,I), I = 1, NEX1) /1, 1, 2, 2, 3, 3/ + DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 2, 1, 3, 1, 1, 2/ + DATA (PDEF(1,I), I = 1, NEX1) /2, 2, 4, 8, 9, 5/ + DATA (PDEF(2,I), I = 1, NEX2) /1, 1, 2, 2, 2, 3, 2, 1, 10/ +C . default values for parameters . + DATA (PARDEF(1,I), I = 1, NEX1) /ZERO, ZERO, ZERO, ZERO, ZERO, + 1 ZERO/ + DATA (PARDEF(2,I), I = 1, NEX2) /.1D-5, .1D-7, .1D7, .1D-6, ZERO, + 1 .1D7, .1D-5, .1D-5, .1D1/ + DATA (PARDEF(3,I), I = 1, NEX3) /ZERO, ZERO/ + DATA (PARDEF(4,I), I = 1, NEX4) /ONE, .1D-1, FOUR, ZERO/ +C . comments on examples . + DATA (NOTES(1,I), I = 1, NEX1) / + 1'Laub 1979, Ex.1', 'Laub 1979, Ex.2: uncontrollable-unobservable d + 2ata', 'Beale/Shafai 1989: model of L-1011 aircraft', 'Bhattacharyy + 3a et al. 1983: binary distillation column', 'Patnaik et al. 1980: + 4tubular ammonia reactor', 'Davison/Gesing 1978: J-100 jet engine'/ + DATA (NOTES(2,I), I = 1, NEX2) / + 1'Arnold/Laub 1984, Ex.1: (A,B) unstabilizable as EPS -> 0', 'Arnol + 2d/Laub 1984, Ex.3: control weighting matrix singular as EPS -> 0', + 3'Kenney/Laub/Wette 1989, Ex.2: ARE ill conditioned for EPS -> oo', + 4'Bai/Qian 1994: ill-conditioned Hamiltonian for EPS -> 0', 'Laub 1 + 5992: H-infinity problem, eigenvalues +/- EPS +/- i', 'Petkov et a + 6l. 1987: increasingly badly scaled Hamiltonian as EPS -> oo', 'Cho + 7w/Kokotovic 1976: magnetic tape control system', 'Arnold/Laub 1984 + 8, Ex.2: poor sep. of closed-loop spectrum as EPS -> 0', 'IFAC Benc + 9hmark Problem #90-06: LQG design for modified Boing B-767 at flutt + 1er condition'/ + DATA (NOTES(3,I), I = 1, NEX3) / + 1'Laub 1979, Ex.4: string of high speed vehicles', 'Laub 1979, Ex.5 + 2: circulant matrices'/ + DATA (NOTES(4,I), I = 1, NEX4) / + 1'Laub 1979, Ex.6: ill-conditioned Riccati equation', 'Rosen/Wang 1 + 2992: lq control of 1-dimensional heat flow','Hench et al. 1995: co + 3upled springs, dashpots and masses','Lang/Penzl 1994: rotating axl + 4e' / +C +C .. Executable Statements .. +C + INFO = 0 + DO 5 I = 1, 9 + VEC(I) = .FALSE. + 5 CONTINUE +C + IF ((NR(1) .NE. 1) .AND. (.NOT. (LSAME(DEF,'N') + 1 .OR. LSAME(DEF,'D')))) THEN + INFO = -1 + ELSE IF ((NR(1) .LT. 1) .OR. (NR(2) .LT. 1) .OR. + 1 (NR(1) .GT. 4) .OR. (NR(2) .GT. NEX(NR(1)))) THEN + INFO = -2 + ELSE IF (NR(1) .GT. 2) THEN + IF (.NOT. LSAME(DEF,'N')) IPAR(1) = NDEF(NR(1),NR(2)) + IF (NR(1) .EQ. 3) THEN + IF (NR(2) .EQ. 1) THEN + IPAR(2) = IPAR(1) + IPAR(3) = IPAR(1) - 1 + IPAR(1) = 2*IPAR(1) - 1 + ELSE IF (NR(2) .EQ. 2) THEN + IPAR(2) = IPAR(1) + IPAR(3) = IPAR(1) + ELSE + IPAR(2) = 1 + IPAR(3) = 1 + END IF + ELSE IF (NR(1) .EQ. 4) THEN + IF (NR(2) .EQ. 3) THEN + L = IPAR(1) + IPAR(2) = 2 + IPAR(3) = 2*L + IPAR(1) = 2*L + ELSE IF (NR(2) .EQ. 4) THEN + L = IPAR(1) + IPAR(2) = L + IPAR(3) = L + IPAR(1) = 2*L-1 + ELSE + IPAR(2) = 1 + IPAR(3) = 1 + END IF + END IF + ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 9) .AND. + 1 (IPAR(1) . EQ. 2)) THEN + IPAR(1) = NDEF(NR(1),NR(2)) + IPAR(2) = MDEF(NR(1),NR(2)) + IPAR(3) = 3 + ELSE + IPAR(1) = NDEF(NR(1),NR(2)) + IPAR(2) = MDEF(NR(1),NR(2)) + IPAR(3) = PDEF(NR(1),NR(2)) + END IF + IF (INFO .NE. 0) GOTO 7 +C + IF (IPAR(1) .LT. 1) THEN + INFO = -4 + ELSE IF (IPAR(1) .GT. LDA) THEN + INFO = -12 + ELSE IF (IPAR(1) .GT. LDB) THEN + INFO = -14 + ELSE IF (IPAR(3) .GT. LDC) THEN + INFO = -16 + ELSE IF (BPAR(2) .AND. (IPAR(1).GT. LDG)) THEN + INFO = -18 + ELSE IF (BPAR(5) .AND. (IPAR(1).GT. LDQ)) THEN + INFO = -20 + ELSE IF (LDX.LT.1) THEN + INFO = -22 + ELSE IF ((NR(1) .EQ. 1) .AND. + $ ((NR(2) .EQ. 1) .OR. (NR(2) .EQ.2))) THEN + IF (IPAR(1) .GT. LDX) INFO = -22 + ELSE IF ((NR(1) .EQ. 2) .AND. (NR(2) .EQ. 1)) THEN + IF (IPAR(1) .GT. LDX) INFO = -22 + ELSE IF ((NR(1) .EQ. 2) .AND. ((NR(2) .GE. 3) .AND. + 1 (NR(2) .LE. 6))) THEN + IF (IPAR(1) .GT. LDX) INFO = -22 + ELSE IF ((NR(1) .EQ. 3) .AND. (NR(2) .EQ. 2)) THEN + IF (IPAR(1) .GT. LDX) INFO = -22 + ELSE IF (LDWORK .LT. N*(MAX(4,N))) THEN + INFO = -24 + END IF +C + 7 CONTINUE + IF (INFO .NE. 0) THEN + CALL XERBLA( 'BB01AD', -INFO ) + RETURN + END IF +C + NSYMM = (IPAR(1)*(IPAR(1)+1))/2 + MSYMM = (IPAR(2)*(IPAR(2)+1))/2 + PSYMM = (IPAR(3)*(IPAR(3)+1))/2 + IF (.NOT. LSAME(DEF,'N')) DPAR(1) = PARDEF(NR(1),NR(2)) +C + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) + CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) + CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) + CALL DLASET('L', MSYMM, 1, ZERO, ZERO, G, 1) + CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) +C + IF (NR(1) .EQ. 1) THEN + IF (NR(2) .EQ. 1) THEN + A(1,2) = ONE + B(2,1) = ONE + Q(1) = ONE + Q(3) = TWO + IDENT = '0101' + CALL DLASET('A', IPAR(1), IPAR(1), ONE, TWO, X, LDX) +C + ELSE IF (NR(2) .EQ. 2) THEN + A(1,1) = FOUR + A(2,1) = -.45D1 + A(1,2) = THREE + A(2,2) = -.35D1 + CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) + Q(1) = 9.0D0 + Q(2) = 6.0D0 + Q(3) = FOUR + IDENT = '0101' + TEMP = ONE + SQRT(TWO) + CALL DLASET('A', IPAR(1), IPAR(1), 6.0D0*TEMP, FOUR*TEMP, X, + 1 LDX) + X(1,1) = 9.0D0*TEMP +C + ELSE IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6)) THEN + WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', + 1 NR(2) , '.dat' + IF ((NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4)) THEN + IDENT = '0101' + ELSE IF (NR(2) .EQ. 5) THEN + IDENT = '0111' + ELSE IF (NR(2) .EQ. 6) THEN + IDENT = '0011' + END IF + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE IF (NR(2) .LE. 6) THEN + DO 10 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) + 1 (A(I,J), J = 1, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 10 CONTINUE + DO 20 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) + 1 (B(I,J), J = 1, IPAR(2)) + IF (IOS .NE. 0) INFO = 1 + 20 CONTINUE + IF (NR(2) .LE. 4) THEN + DO 30 I = 1, IPAR(1) + POS = (I-1)*IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) (DWORK(POS+J), + 1 J = 1,IPAR(1)) + 30 CONTINUE + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) + END IF + ELSE IF (NR(2) .EQ. 6) THEN + DO 35 I = 1, IPAR(3) + READ (1, FMT = *, IOSTAT = IOS) + 1 (C(I,J), J = 1, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 35 CONTINUE + END IF + CLOSE(1) + END IF + END IF +C + ELSE IF (NR(1) .EQ. 2) THEN + IF (NR(2) .EQ. 1) THEN + A(1,1) = ONE + A(2,2) = -TWO + B(1,1) = DPAR(1) + CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) + IDENT = '0011' + IF (DPAR(1) .NE. ZERO) THEN + TEMP = DLAPY2(ONE, DPAR(1)) + X(1,1) = (ONE + TEMP)/DPAR(1)/DPAR(1) + X(2,1) = ONE/(TWO + TEMP) + X(1,2) = X(2,1) + TTEMP = DPAR(1)*X(1,2) + TEMP = (ONE - TTEMP) * (ONE + TTEMP) + X(2,2) = TEMP / FOUR + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 2) THEN + A(1,1) = -.1D0 + A(2,2) = -.2D-1 + B(1,1) = .1D0 + B(2,1) = .1D-2 + B(2,2) = .1D-1 + CALL DLASET('L', MSYMM, 1, ONE, ONE, G, MSYMM) + G(1) = G(1) + DPAR(1) + C(1,1) = .1D2 + C(1,2) = .1D3 + IDENT = '0010' +C + ELSE IF (NR(2) .EQ. 3) THEN + A(1,2) = DPAR(1) + B(2,1) = ONE + IDENT = '0111' + IF (DPAR(1) .NE. ZERO) THEN + TEMP = SQRT(ONE + TWO*DPAR(1)) + CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, X, LDX) + X(1,1) = X(1,1)/DPAR(1) + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 4) THEN + TEMP = DPAR(1) + ONE + CALL DLASET('A', IPAR(1), IPAR(1), ONE, TEMP, A, LDA) + Q(1) = DPAR(1)**2 + Q(3) = Q(1) + IDENT = '1101' + X(1,1) = TWO*TEMP + SQRT(TWO)*(SQRT(TEMP**2 + ONE) + DPAR(1)) + X(1,1) = X(1,1)/TWO + X(2,2) = X(1,1) + TTEMP = X(1,1) - TEMP + IF (TTEMP .NE. ZERO) THEN + X(2,1) = X(1,1) / TTEMP + X(1,2) = X(2,1) + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 5) THEN + A(1,1) = THREE - DPAR(1) + A(2,1) = FOUR + A(1,2) = ONE + A(2,2) = TWO - DPAR(1) + CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) + Q(1) = FOUR*DPAR(1) - 11.0D0 + Q(2) = TWO*DPAR(1) - 5.0D0 + Q(3) = TWO*DPAR(1) - TWO + IDENT = '0101' + CALL DLASET('A', IPAR(1), IPAR(1), ONE, ONE, X, LDX) + X(1,1) = TWO +C + ELSE IF (NR(2) .EQ. 6) THEN + IF (DPAR(1) .NE. ZERO) THEN + A(1,1) = DPAR(1) + A(2,2) = DPAR(1)*TWO + A(3,3) = DPAR(1)*THREE +C .. set C = V .. + TEMP = TWO/THREE + CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, + 1 C, LDC) + CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, + 1 ZERO, DWORK, IPAR(1)) + CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, + 1 IPAR(1), ZERO, A, LDA) +C .. G = R ! .. + G(1) = DPAR(1) + G(4) = DPAR(1) + G(6) = DPAR(1) + Q(1) = ONE/DPAR(1) + Q(4) = ONE + Q(6) = DPAR(1) + IDENT = '1000' + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) + TEMP = DPAR(1)**2 + X(1,1) = TEMP + SQRT(TEMP**2 + ONE) + X(2,2) = TEMP*TWO + SQRT(FOUR*TEMP**2 + DPAR(1)) + X(3,3) = TEMP*THREE + DPAR(1)*SQRT(9.0D0*TEMP + ONE) + CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, + 1 ZERO, DWORK, IPAR(1)) + CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, + 1 IPAR(1), ZERO, X, LDX) + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 7) THEN + IF (DPAR(1) .NE. ZERO) THEN + A(1,2) = .400D0 + A(2,3) = .345D0 + A(3,2) = -.524D0/DPAR(1) + A(3,3) = -.465D0/DPAR(1) + A(3,4) = .262D0/DPAR(1) + A(4,4) = -ONE/DPAR(1) + B(4,1) = ONE/DPAR(1) + C(1,1) = ONE + C(2,3) = ONE + IDENT = '0011' + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 8) THEN + A(1,1) = -DPAR(1) + A(2,1) = -ONE + A(1,2) = ONE + A(2,2) = -DPAR(1) + A(3,3) = DPAR(1) + A(4,3) = -ONE + A(3,4) = ONE + A(4,4) = DPAR(1) + CALL DLASET('L', IPAR(1), IPAR(2), ONE, ONE, B, LDB) + CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) + IDENT = '0011' +C + ELSE IF (NR(2) .EQ. 9) THEN + IF (IPAR(3) .EQ. 10) THEN +C .. read LQR CARE ... + WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', + 1 NR(2), '1.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + DO 36 I = 1, 27, 2 + READ (1, FMT = *, IOSTAT = IOS) + 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) + IF (IOS .NE. 0) INFO = 1 + 36 CONTINUE + DO 37 I = 30, 44, 2 + READ (1, FMT = *, IOSTAT = IOS) + 1 ((A(I+J,I+K), K = 0, 1), J = 0, 1) + IF (IOS .NE. 0) INFO = 1 + 37 CONTINUE + DO 38 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) + 1 (A(I,J), J = 46, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 38 CONTINUE + A(29,29) = -.5301D1 + B(48,1) = .8D06 + B(51,2) = .8D06 + G(1) = .3647D03 + G(3) = .1459D02 + DO 39 I = 1,6 + READ (1, FMT = *, IOSTAT = IOS) + 1 (C(I,J), J = 1,45) + IF (IOS .NE. 0) INFO = 1 + 39 CONTINUE + C(7,47) = ONE + C(8,46) = ONE + C(9,50) = ONE + C(10,49) = ONE + Q(11) = .376D-13 + Q(20) = .120D-12 + Q(41) = .245D-11 + END IF + ELSE +C .. read Kalman filter CARE .. + WRITE (CHPAR(1:12), '(A,I1,A,I1,A)') 'BB01', NR(1), '0', + 1 NR(2), '2.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:12)) + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + DO 40 I = 1, 27, 2 + READ (1, FMT = *, IOSTAT = IOS) + 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) + IF (IOS .NE. 0) INFO = 1 + 40 CONTINUE + DO 41 I = 30, 44, 2 + READ (1, FMT = *, IOSTAT = IOS) + 1 ((A(I+K,I+J), K = 0, 1), J = 0, 1) + IF (IOS .NE. 0) INFO = 1 + 41 CONTINUE + DO 42 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) + 1 (A(J,I), J = 46, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 42 CONTINUE + A(29,29) = -.5301D1 + DO 43 J = 1, IPAR(2) + READ (1, FMT = *, IOSTAT = IOS) + 1 (B(I,J), I = 1, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 43 CONTINUE + G(1) = .685D-5 + G(3) = .373D3 + C(1,52) = .3713 + C(1,53) = .1245D1 + C(2,48) = .8D6 + C(2,54) = ONE + C(3,51) = .8D6 + C(3,55) = ONE + Q(1) = .28224D5 + Q(4) = .2742D-4 + Q(6) = .6854D-3 + END IF + END IF + CLOSE(1) + IDENT = '0000' + END IF +C + ELSE IF (NR(1) .EQ. 3) THEN + IF (NR(2) .EQ. 1) THEN + DO 45 I = 1, IPAR(1) + IF (MOD(I,2) .EQ. 1) THEN + A(I,I) = -ONE + B(I,(I+1)/2) = ONE + ELSE + A(I,I-1) = ONE + A(I,I+1) = -ONE + C(I/2,I) = ONE + END IF + 45 CONTINUE + ISYMM = 1 + DO 50 I = IPAR(3), 1, -1 + Q(ISYMM) = 10.0D0 + ISYMM = ISYMM + I + 50 CONTINUE + IDENT = '0001' +C + ELSE IF (NR(2) .EQ. 2) THEN + DO 60 I = 1, IPAR(1) + A(I,I) = -TWO + IF (I .LT. IPAR(1)) THEN + A(I,I+1) = ONE + A(I+1,I) = ONE + END IF + 60 CONTINUE + A(1,IPAR(1)) = ONE + A(IPAR(1),1) = ONE + IDENT = '1111' + TEMP = TWO * PI / DBLE(IPAR(1)) + DO 70 I = 1, IPAR(1) + DWORK(I) = COS(TEMP*DBLE(I-1)) + DWORK(IPAR(1)+I) = -TWO + TWO*DWORK(I) + + 1 SQRT(5.0D0 + FOUR*DWORK(I)*(DWORK(I) - TWO)) + 70 CONTINUE + DO 90 J = 1, IPAR(1) + DO 80 I = 1, IPAR(1) + DWORK(2*IPAR(1)+I) = COS(TEMP*DBLE(I-1)*DBLE(J-1)) + 80 CONTINUE + X(J,1) = DDOT(IPAR(1), DWORK(IPAR(1)+1), 1, + 1 DWORK(2*IPAR(1)+1), 1)/DBLE(IPAR(1)) + 90 CONTINUE +C .. set up circulant solution matrix .. + DO 100 I = 2, IPAR(1) + CALL DCOPY(IPAR(1)-I+1, X(1,1), 1, X(I,I), 1) + CALL DCOPY(I-1, X(IPAR(1)-I+2,1), 1, X(1,I), 1) + 100 CONTINUE + END IF +C + ELSE IF (NR(1) .EQ. 4) THEN + IF (NR(2) .EQ. 1) THEN +C .. set up remaining parameter .. + IF (.NOT. LSAME(DEF,'N')) THEN + DPAR(1) = ONE + DPAR(2) = ONE + END IF + CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) + B(IPAR(1),1) = ONE + C(1,1) = ONE + Q(1) = DPAR(1) + G(1) = DPAR(2) + IDENT = '0000' +C + ELSE IF (NR(2) .EQ. 2) THEN +C .. set up remaining parameters .. + APPIND = DBLE(IPAR(1) + 1) + IF (.NOT. LSAME(DEF,'N')) THEN + DPAR(1) = PARDEF(NR(1), NR(2)) + DPAR(2) = ONE + DPAR(3) = ONE + DPAR(4) = .2D0 + DPAR(5) = .3D0 + DPAR(6) = .2D0 + DPAR(7) = .3D0 + END IF +C .. set up stiffness matrix .. + TEMP = -DPAR(1)*APPIND + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, TWO*TEMP, A, LDA) + DO 110 I = 1, IPAR(1) - 1 + A(I+1,I) = -TEMP + A(I,I+1) = -TEMP + 110 CONTINUE +C .. set up Gramian, stored by diagonals .. + TEMP = ONE/(6.0D0*APPIND) + CALL DLASET('L', IPAR(1), 1, FOUR*TEMP, FOUR*TEMP, DWORK, + 1 IPAR(1)) + CALL DLASET('L', IPAR(1)-1, 1, TEMP, TEMP, DWORK(IPAR(1)+1), + 1 IPAR(1)) + CALL DPTTRF(IPAR(1), DWORK(1), DWORK(IPAR(1)+1), INFO) +C .. A = (inverse of Gramian) * (stiffness matrix) .. + CALL DPTTRS(IPAR(1), IPAR(1), DWORK(1), DWORK(IPAR(1)+1), + 1 A, LDA, INFO) +C .. compute B, C .. + DO 120 I = 1, IPAR(1) + B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) + B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) + C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) + C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) + IF (B1 .GE. B2) THEN + B(I,1) = ZERO + ELSE + B(I,1) = B2 - B1 + TEMP = MIN(B2, DBLE(I)/APPIND) + IF (B1 .LT. TEMP) THEN + B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO + B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) + END IF + TEMP = MAX(B1, DBLE(I)/APPIND) + IF (TEMP .LT. B2) THEN + B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO + B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) + END IF + END IF + IF (C1 .GE. C2) THEN + C(1,I) = ZERO + ELSE + C(1,I) = C2 - C1 + TEMP = MIN(C2, DBLE(I)/APPIND) + IF (C1 .LT. TEMP) THEN + C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO + C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) + END IF + TEMP = MAX(C1, DBLE(I)/APPIND) + IF (TEMP .LT. C2) THEN + C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO + C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) + END IF + END IF + 120 CONTINUE + CALL DSCAL(IPAR(1), DPAR(2), B(1,1), 1) + CALL DSCAL(IPAR(1), DPAR(3), C(1,1), LDC) + CALL DPTTRS(IPAR(1), 1, DWORK(1), DWORK(IPAR(1)+1), B, LDB, + 1 INFO) + IDENT = '0011' +C + ELSE IF (NR(2) .EQ. 3) THEN +C .. set up remaining parameters .. + IF (.NOT. LSAME(DEF,'N')) THEN + DPAR(1) = PARDEF(NR(1),NR(2)) + DPAR(2) = FOUR + DPAR(3) = ONE + END IF + IF (DPAR(1) . NE. 0) THEN + CALL DLASET('A', L, L, ZERO, ONE, A(1,L+1), LDA) + TEMP = DPAR(3) / DPAR(1) + A(L+1,1) = -TEMP + A(L+1,2) = TEMP + A(IPAR(1),L-1) = TEMP + A(IPAR(1),L) = -TEMP + TTEMP = TWO*TEMP + DO 130 I = 2, L-1 + A(L+I,I) = -TTEMP + A(L+I,I+1) = TEMP + A(L+I,I-1) = TEMP + 130 CONTINUE + CALL DLASET('A', L, L, ZERO, -DPAR(2)/DPAR(1), A(L+1,L+1), + 1 LDA) + B(L+1,1) = ONE / DPAR(1) + B(IPAR(1),IPAR(2)) = -ONE / DPAR(1) + IDENT = '0111' + ELSE + INFO = 2 + END IF +C + ELSE IF (NR(2) .EQ. 4) THEN + IF (.NOT. LSAME(DEF,'N')) WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') + 1 'BB01', NR(1), '0', NR(2), '.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + READ (1, FMT = *, IOSTAT = IOS) (DWORK(I), I = 1, 4*L-2) + IF (IOS .NE. 0) INFO = 1 + END IF + CLOSE(1) + IF (INFO .EQ. 0) THEN + CALL DLASET('A', L-1, L-1, ZERO, ONE, A(L+1,2), LDA) + POS = 2*L + 1 + A(1,2) = - DWORK(POS) / DWORK(1) + DO 140 I = 2, L + TEMP = DWORK(POS) / DWORK(I-1) + TTEMP = DWORK(POS) / DWORK(I) + IF (I .GT. 2) A(I-1,I) = TEMP + A(I,I) = -(TEMP + TTEMP) + IF (I .LT. L) A(I+1,I) = TTEMP + POS = POS + 1 + 140 CONTINUE + POS = L + TEMP = DWORK(POS+1) / DWORK(1) + A(1,1) = -TEMP + DO 160 I = 2, L + TTEMP = TEMP + TEMP = DWORK(POS+I) / DWORK(I) + SUM = TTEMP - TEMP + A(I,1) = -SUM + A(I,I) = A(I,I) - TEMP + DO 150 J = 2, I-2 + A(I,J) = SUM + 150 CONTINUE + IF (I .GT. 2) A(I,I-1) = A(I,I-1) + SUM + 160 CONTINUE + POS = 3*L + A(1,L+1) = -DWORK(3*L)/DWORK(1) + DO 170 I = 2, L + TEMP = DWORK(POS) / DWORK(I-1) + TTEMP = DWORK(POS) / DWORK(I) + IF (I .GT. 2) A(I-1,L+I-1) = TEMP + A(I,L+I-1) = -(TEMP + TTEMP) + IF (I .LT. L) A(I+1,L+I-1) = TTEMP + POS = POS + 1 + 170 CONTINUE + B(1,1) = ONE/DWORK(1) + DO 180 I = 1, L + TEMP = ONE/DWORK(I) + IF (I .GT. 1) B(I,I) = -TEMP + IF (I .LT. L) B(I+1,I) = TEMP + 180 CONTINUE + C(1,1) = ONE + Q(1) = ONE + POS = 2*L - 1 + ISYMM = L + 1 + DO 190 I = 2, L + TEMP = DWORK(POS+I) + TTEMP = DWORK(POS+L+I-1) + C(I,I) = TEMP + C(I,L+I-1) = TTEMP + Q(ISYMM) = ONE / (TEMP*TEMP + TTEMP*TTEMP) + ISYMM = ISYMM + L - I + 1 + 190 CONTINUE + IDENT = '0001' + END IF + END IF + END IF +C + IF (INFO .NE. 0) GOTO 2001 +C .. set up data in required format .. +C + IF (BPAR(1)) THEN +C .. G is to be returned in product form .. + GDIMM = IPAR(1) + IF (IDENT(4:4) .EQ. '0') THEN +C .. invert R using Cholesky factorization, store in G .. + CALL DPPTRF('L', IPAR(2), G, INFO) + IF (INFO .EQ. 0) THEN + CALL DPPTRI('L', IPAR(2), G, INFO) + IF (IDENT(1:1) .EQ. '0') THEN +C .. B is not identity matrix .. + DO 200 I = 1, IPAR(1) + CALL DSPMV('L', IPAR(2), ONE, G, B(I,1), LDB, ZERO, + 1 DWORK((I-1)*IPAR(1)+1), 1) + 200 CONTINUE + CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), + 1 B(1,1), LDB, ZERO, G, 1) + ISYMM = IPAR(1) + 1 + DO 210 I = 2, IPAR(1) + CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), + 1 B(I,1), LDB, ZERO, B(1,1), LDB) + CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, G(ISYMM), 1) + ISYMM = ISYMM + (IPAR(1) - I + 1) + 210 CONTINUE + END IF + ELSE + IF (INFO .GT. 0) THEN + INFO = 3 + GOTO 2001 + END IF + END IF + ELSE +C .. R = identity .. + IF (IDENT(1:1) .EQ. '0') THEN +C .. B is not identity matrix .. + IF (IPAR(2) .EQ. 1) THEN + CALL DLASET('L', NSYMM, 1, ZERO, ZERO, G, 1) + CALL DSPR('L', IPAR(1), ONE, B, 1, G) + ELSE + CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, + 1 B, LDB, ZERO, DWORK, IPAR(1)) + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), G) + END IF + ELSE +C .. B = R = identity .. + ISYMM = 1 + DO 220 I = IPAR(1), 1, -1 + G(ISYMM) = ONE + ISYMM = ISYMM + I + 220 CONTINUE + END IF + END IF + ELSE + GDIMM = IPAR(2) + IF (IDENT(1:1) .EQ. '1') + 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) + IF (IDENT(4:4) .EQ. '1') THEN + ISYMM = 1 + DO 230 I = IPAR(2), 1, -1 + G(ISYMM) = ONE + ISYMM = ISYMM + I + 230 CONTINUE + END IF + END IF +C + IF (BPAR(4)) THEN +C .. Q is to be returned in product form .. + QDIMM = IPAR(1) + IF (IDENT(3:3) .EQ. '0') THEN + IF (IDENT(2:2) .EQ. '0') THEN +C .. C is not identity matrix .. + DO 240 I = 1, IPAR(1) + CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, + 1 DWORK((I-1)*IPAR(1)+1), 1) + 240 CONTINUE +C .. use Q(1:IPAR(1)) as workspace and compute the first column +C of Q in the end .. + ISYMM = IPAR(1) + 1 + DO 250 I = 2, IPAR(1) + CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), + 1 C(1,I), 1, ZERO, Q(1), 1) + CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) + ISYMM = ISYMM + (IPAR(1) - I + 1) + 250 CONTINUE + CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), + 1 C(1,1), 1, ZERO, Q, 1) + END IF + ELSE +C .. Q = identity .. + IF (IDENT(2:2) .EQ. '0') THEN +C .. C is not identity matrix .. + IF (IPAR(3) .EQ. 1) THEN + CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) + CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) + ELSE + CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, + 1 ZERO, DWORK, IPAR(1)) + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) + END IF + ELSE +C .. C = Q = identity .. + ISYMM = 1 + DO 260 I = IPAR(1), 1, -1 + Q(ISYMM) = ONE + ISYMM = ISYMM + I + 260 CONTINUE + END IF + END IF + ELSE + QDIMM = IPAR(3) + IF (IDENT(2:2) .EQ. '1') + 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) + IF (IDENT(3:3) .EQ. '1') THEN + ISYMM = 1 + DO 270 I = IPAR(3), 1, -1 + Q(ISYMM) = ONE + ISYMM = ISYMM + I + 270 CONTINUE + END IF + END IF +C +C .. unpack symmetric matrices if desired .. + IF (BPAR(2)) THEN + ISYMM = (GDIMM * (GDIMM + 1)) / 2 + CALL DCOPY(ISYMM, G, 1, DWORK, 1) + CALL MA02DD('Unpack', 'Lower', GDIMM, G, LDG, DWORK) + CALL MA02ED('Lower', GDIMM, G, LDG) + ELSE IF (BPAR(3)) THEN + CALL MA02DD('Unpack', 'Lower', GDIMM, DWORK, GDIMM, G) + CALL MA02ED('Lower', GDIMM, DWORK, GDIMM) + CALL MA02DD('Pack', 'Upper', GDIMM, DWORK, GDIMM, G) + END IF + IF (BPAR(5)) THEN + ISYMM = (QDIMM * (QDIMM + 1)) / 2 + CALL DCOPY(ISYMM, Q, 1, DWORK, 1) + CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) + CALL MA02ED('Lower', QDIMM, Q, LDQ) + ELSE IF (BPAR(6)) THEN + CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) + CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) + CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) + END IF +C +C ...set VEC... + VEC(1) = .TRUE. + VEC(2) = .TRUE. + VEC(3) = .TRUE. + VEC(4) = .TRUE. + VEC(5) = .NOT. BPAR(1) + VEC(6) = .NOT. BPAR(4) + VEC(7) = .TRUE. + VEC(8) = .TRUE. + IF (NR(1) .EQ. 1) THEN + IF ((NR(2) .EQ. 1) .OR. (NR(2) .EQ. 2)) VEC(9) = .TRUE. + ELSE IF (NR(1) .EQ. 2) THEN + IF ((NR(2) .EQ. 1) .OR. ((NR(2) .GE. 3) .AND. (NR(2) .LE. 6))) + 1 VEC(9) = .TRUE. + ELSE IF (NR(1) .EQ. 3) THEN + IF (NR(2) .EQ. 2) VEC(9) = .TRUE. + END IF + CHPAR = NOTES(NR(1),NR(2)) + N = IPAR(1) + M = IPAR(2) + P = IPAR(3) + 2001 CONTINUE + RETURN +C *** Last line of BB01AD *** + END diff --git a/mex/sources/libslicot/BB02AD.f b/mex/sources/libslicot/BB02AD.f new file mode 100644 index 000000000..b9edfa346 --- /dev/null +++ b/mex/sources/libslicot/BB02AD.f @@ -0,0 +1,1017 @@ + SUBROUTINE BB02AD(DEF, NR, DPAR, IPAR, BPAR, CHPAR, VEC, N, M, P, + 1 A, LDA, B, LDB, C, LDC, Q, LDQ, R, LDR, S, LDS, + 2 X, LDX, DWORK, LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate the benchmark examples for the numerical solution of +C discrete-time algebraic Riccati equations (DAREs) of the form +C +C T T T -1 T T +C 0 = A X A - X - (A X B + S) (R + B X B) (B X A + S ) + Q +C +C as presented in [1]. Here, A,Q,X are real N-by-N matrices, B,S are +C N-by-M, and R is M-by-M. The matrices Q and R are symmetric and Q +C may be given in factored form +C +C T +C (I) Q = C Q0 C . +C +C Here, C is P-by-N and Q0 is P-by-P. If R is nonsingular and S = 0, +C the DARE can be rewritten equivalently as +C +C T -1 +C 0 = X - A X (I_n + G X) A - Q, +C +C where I_n is the N-by-N identity matrix and +C +C -1 T +C (II) G = B R B . +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER +C This parameter specifies if the default parameters are +C to be used or not. +C = 'N' or 'n' : The parameters given in the input vectors +C xPAR (x = 'D', 'I', 'B', 'CH') are used. +C = 'D' or 'd' : The default parameters for the example +C are used. +C This parameter is not meaningful if NR(1) = 1. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension (2) +C This array determines the example for which DAREX returns +C data. NR(1) is the group of examples. +C NR(1) = 1 : parameter-free problems of fixed size. +C NR(1) = 2 : parameter-dependent problems of fixed size. +C NR(1) = 3 : parameter-free problems of scalable size. +C NR(1) = 4 : parameter-dependent problems of scalable size. +C NR(2) is the number of the example in group NR(1). +C Let NEXi be the number of examples in group i. Currently, +C NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1. +C 1 <= NR(1) <= 4; +C 0 <= NR(2) <= NEXi, where i = NR(1). +C +C DPAR (input/output) DOUBLE PRECISION array, dimension (4) +C Double precision parameter vector. For explanation of the +C parameters see [1]. +C DPAR(1) defines the parameter 'epsilon' for +C examples NR = 2.2,2.3,2.4, the parameter 'tau' +C for NR = 2.5, and the 1-by-1 matrix R for NR = 2.1,4.1. +C For Example 2.5, DPAR(2) - DPAR(4) define in +C consecutive order 'D', 'K', and 'r'. +C NOTE that DPAR is overwritten with default values +C if DEF = 'D' or 'd'. +C +C IPAR (input/output) INTEGER array, dimension (3) +C On input, IPAR(1) determines the actual state dimension, +C i.e., the order of the matrix A as follows: +C NR(1) = 1, NR(1) = 2 : IPAR(1) is ignored. +C NR = NR(1).NR(2) = 4.1 : IPAR(1) determines the order of +C the output matrix A. +C NOTE that IPAR(1) is overwritten for Examples 1.1-2.3. For +C the other examples, IPAR(1) is overwritten if the default +C parameters are to be used. +C On output, IPAR(1) contains the order of the matrix A. +C +C On input, IPAR(2) is the number of colums in the matrix B +C and the order of the matrix R (in control problems, the +C number of inputs of the system). Currently, IPAR(2) is +C fixed for all examples and thus is not referenced on +C input. +C On output, IPAR(2) is the number of columns of the +C matrix B from (I). +C +C On input, IPAR(3) is the number of rows in the matrix C +C (in control problems, the number of outputs of the +C system). Currently, IPAR(3) is fixed for all examples +C and thus is not referenced on input. +C On output, IPAR(3) is the number of rows of the matrix C +C from (I). +C +C NOTE that IPAR(2) and IPAR(3) are overwritten and +C IPAR(2) <= IPAR(1) and IPAR(3) <= IPAR(1) for all +C examples. +C +C BPAR (input) LOGICAL array, dimension (7) +C This array defines the form of the output of the examples +C and the storage mode of the matrices Q, G or R. +C BPAR(1) = .TRUE. : Q is returned. +C BPAR(1) = .FALSE. : Q is returned in factored form, i.e., +C Q0 and C from (I) are returned. +C BPAR(2) = .TRUE. : The matrix returned in array Q (i.e., +C Q if BPAR(1) = .TRUE. and Q0 if +C BPAR(1) = .FALSE.) is stored as full +C matrix. +C BPAR(2) = .FALSE. : The matrix returned in array Q is +C provided in packed storage mode. +C BPAR(3) = .TRUE. : If BPAR(2) = .FALSE., the matrix +C returned in array Q is stored in upper +C packed mode, i.e., the upper triangle +C of a symmetric n-by-n matrix is stored +C by columns, e.g., the matrix entry +C Q(i,j) is stored in the array entry +C Q(i+j*(j-1)/2) for i <= j. +C Otherwise, this entry is ignored. +C BPAR(3) = .FALSE. : If BPAR(2) = .FALSE., the matrix +C returned in array Q is stored in lower +C packed mode, i.e., the lower triangle +C of a symmetric n-by-n matrix is stored +C by columns, e.g., the matrix entry +C Q(i,j) is stored in the array entry +C Q(i+(2*n-j)*(j-1)/2) for j <= i. +C Otherwise, this entry is ignored. +C BPAR(4) = .TRUE. : The product G in (II) is returned. +C BPAR(4) = .FALSE. : G is returned in factored form, i.e., +C B and R from (II) are returned. +C BPAR(5) = .TRUE. : The matrix returned in array R (i.e., +C G if BPAR(4) = .TRUE. and R if +C BPAR(4) = .FALSE.) is stored as full +C matrix. +C BPAR(5) = .FALSE. : The matrix returned in array R is +C provided in packed storage mode. +C BPAR(6) = .TRUE. : If BPAR(5) = .FALSE., the matrix +C returned in array R is stored in upper +C packed mode (see above). +C Otherwise, this entry is ignored. +C BPAR(6) = .FALSE. : If BPAR(5) = .FALSE., the matrix +C returned in array R is stored in lower +C packed mode (see above). +C Otherwise, this entry is ignored. +C BPAR(7) = .TRUE. : The coefficient matrix S of the DARE +C is returned in array S. +C BPAR(7) = .FALSE. : The coefficient matrix S of the DARE +C is not returned. +C NOTE that there are no default values for BPAR. If all +C entries are declared to be .TRUE., then matrices Q, G or R +C are returned in conventional storage mode, i.e., as +C N-by-N or M-by-M arrays where the array element Z(I,J) +C contains the matrix entry Z_{i,j}. +C +C CHPAR (output) CHARACTER*255 +C On output, this string contains short information about +C the chosen example. +C +C VEC (output) LOGICAL array, dimension (10) +C Flag vector which displays the availability of the output +C data: +C VEC(j), j=1,2,3, refer to N, M, and P, respectively, and +C are always .TRUE. +C VEC(4) refers to A and is always .TRUE. +C VEC(5) is .TRUE. if BPAR(4) = .FALSE., i.e., the factors B +C and R from (II) are returned. +C VEC(6) is .TRUE. if BPAR(1) = .FALSE., i.e., the factors C +C and Q0 from (I) are returned. +C VEC(7) refers to Q and is always .TRUE. +C VEC(8) refers to R and is always .TRUE. +C VEC(9) is .TRUE. if BPAR(7) = .TRUE., i.e., the matrix S +C is returned. +C VEC(10) refers to X and is .TRUE. if the exact solution +C matrix is available. +C NOTE that VEC(i) = .FALSE. for i = 1 to 10 if on exit +C INFO .NE. 0. +C +C N (output) INTEGER +C The order of the matrices A, X, G if BPAR(4) = .TRUE., and +C Q if BPAR(1) = .TRUE. +C +C M (output) INTEGER +C The number of columns in the matrix B (or the dimension of +C the control input space of the underlying dynamical +C system). +C +C P (output) INTEGER +C The number of rows in the matrix C (or the dimension of +C the output space of the underlying dynamical system). +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C coefficient matrix A of the DARE. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If (BPAR(4) = .FALSE.), then the leading N-by-M part +C of this array contains the coefficient matrix B of +C the DARE. Otherwise, B is used as workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C If (BPAR(1) = .FALSE.), then the leading P-by-N part +C of this array contains the matrix C of the factored +C form (I) of Q. Otherwise, C is used as workspace. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= P. +C +C Q (output) DOUBLE PRECISION array, dimension (NQ) +C If (BPAR(1) = .TRUE.) and (BPAR(2) = .TRUE.), then +C NQ = LDQ*N. +C IF (BPAR(1) = .TRUE.) and (BPAR(2) = .FALSE.), then +C NQ = N*(N+1)/2. +C If (BPAR(1) = .FALSE.) and (BPAR(2) = .TRUE.), then +C NQ = LDQ*P. +C IF (BPAR(1) = .FALSE.) and (BPAR(2) = .FALSE.), then +C NQ = P*(P+1)/2. +C The symmetric matrix contained in array Q is stored +C according to BPAR(2) and BPAR(3). +C +C LDQ INTEGER +C If conventional storage mode is used for Q, i.e., +C BPAR(2) = .TRUE., then Q is stored like a 2-dimensional +C array with leading dimension LDQ. If packed symmetric +C storage mode is used, then LDQ is irrelevant. +C LDQ >= N if BPAR(1) = .TRUE.; +C LDQ >= P if BPAR(1) = .FALSE.. +C +C R (output) DOUBLE PRECISION array, dimension (MR) +C If (BPAR(4) = .TRUE.) and (BPAR(5) = .TRUE.), then +C MR = LDR*N. +C IF (BPAR(4) = .TRUE.) and (BPAR(5) = .FALSE.), then +C MR = N*(N+1)/2. +C If (BPAR(4) = .FALSE.) and (BPAR(5) = .TRUE.), then +C MR = LDR*M. +C IF (BPAR(4) = .FALSE.) and (BPAR(5) = .FALSE.), then +C MR = M*(M+1)/2. +C The symmetric matrix contained in array R is stored +C according to BPAR(5) and BPAR(6). +C +C LDR INTEGER +C If conventional storage mode is used for R, i.e., +C BPAR(5) = .TRUE., then R is stored like a 2-dimensional +C array with leading dimension LDR. If packed symmetric +C storage mode is used, then LDR is irrelevant. +C LDR >= N if BPAR(4) = .TRUE.; +C LDR >= M if BPAR(4) = .FALSE.. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,M) +C If (BPAR(7) = .TRUE.), then the leading N-by-M part of +C this array contains the coefficient matrix S of the DARE. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= 1, and +C LDS >= N if BPAR(7) = .TRUE.. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,NX) +C If an exact solution is available (NR = 1.1,1.3,1.4,2.1, +C 2.3,2.4,2.5,4.1), then NX = N and the leading N-by-N part +C of this array contains the solution matrix X. +C Otherwise, X is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= 1, and +C LDX >= N if an exact solution is available. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= N*N. +C +C Error Indicator +C +C INFO INTEGER +C = 0 : successful exit; +C < 0 : if INFO = -i, the i-th argument had an illegal +C value; +C = 1 : data file could not be opened or had wrong format; +C = 2 : division by zero; +C = 3 : G can not be computed as in (II) due to a singular R +C matrix. This error can only occur if +C BPAR(4) = .TRUE.. +C +C REFERENCES +C +C [1] Abels, J. and Benner, P. +C DAREX - A Collection of Benchmark Examples for Discrete-Time +C Algebraic Riccati Equations (Version 2.0). +C SLICOT Working Note 1999-16, November 1999. Available from +C http://www.win.tue.nl/niconet/NIC2/reports.html. +C +C This is an updated and extended version of +C +C [2] Benner, P., Laub, A.J., and Mehrmann, V. +C A Collection of Benchmark Examples for the Numerical Solution +C of Algebraic Riccati Equations II: Discrete-Time Case. +C Technical Report SPC 95_23, Fak. f. Mathematik, +C TU Chemnitz-Zwickau (Germany), December 1995. +C +C FURTHER COMMENTS +C +C Some benchmark examples read data from the data files provided +C with the collection. +C +C CONTRIBUTOR +C +C Peter Benner (Universitaet Bremen), November 25, 1999. +C +C For questions concerning the collection or for the submission of +C test examples, please send e-mail to benner@math.uni-bremen.de. +C +C REVISIONS +C +C 1999, December 23 (V. Sima). +C +C KEYWORDS +C +C Discrete-time algebraic Riccati equation. +C +C ****************************************************************** +C +C .. Parameters .. +C . # of examples available , # of examples with fixed size. . + INTEGER NEX1, NEX2, NEX3, NEX4, NMAX + PARAMETER ( NEX1 = 13, NEX2 = 5, NEX3 = 0, NEX4 = 1 ) + PARAMETER ( NMAX = 13 ) + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, FIVE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + 1 THREE = 3.0D0, FOUR = 4.0D0, FIVE = 5.0D0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDQ, LDR, LDS, LDWORK, LDX, + $ M, N, P + CHARACTER DEF +C +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DPAR(*), DWORK(*), + 1 Q(*), R(*), S(LDS,*), X(LDX,*) + INTEGER IPAR(3), NR(2) + CHARACTER CHPAR*255 + LOGICAL BPAR(7), VEC(10) +C +C .. Local Scalars .. + INTEGER I, IOS, ISYMM, J, MSYMM, NSYMM, PSYMM, QDIMM, + 1 RDIMM + DOUBLE PRECISION ALPHA, BETA, TEMP +C +C ..Local Arrays .. + INTEGER MDEF(2,NMAX), NDEF(4,NMAX), NEX(4), PDEF(2,NMAX) + CHARACTER IDENT*4 + CHARACTER*255 NOTES(4,NMAX) +C +C .. External Functions .. +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C +C .. External Subroutines .. +C . BLAS . + EXTERNAL DCOPY, DGEMV, DSPMV, DSPR, DSYMM, DSYRK +C . LAPACK . + EXTERNAL DLASET, DPPTRF, DPPTRI, DRSCL, XERBLA +C . SLICOT . + EXTERNAL MA02DD, MA02ED +C +C .. Intrinsic Functions .. + INTRINSIC SQRT +C +C .. Data Statements .. +C . default values for dimensions . + DATA NEX /NEX1, NEX2, NEX3, NEX4/ + DATA (NDEF(1,I), I = 1, NEX1) /2, 2, 2, 3, 4, 4, 4, 5, 6, 9, + 1 11, 13, 26/ + DATA (NDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 4/ + DATA (NDEF(4,I), I = 1, NEX4) /100/ + DATA (MDEF(1,I), I = 1, NEX1) /1, 2, 1, 2, 2, 2, 4, 2, 2, 3, + 1 2, 2, 6/ + DATA (MDEF(2,I), I = 1, NEX2) /1, 2, 1, 3, 1/ + DATA (PDEF(1,I), I = 1, NEX1) /1, 2, 2, 3, 4, 4, 4, 5, 2, 2, + 1 4, 4, 12/ + DATA (PDEF(2,I), I = 1, NEX2) /2, 2, 2, 3, 1/ +C . comments on examples . + DATA (NOTES(1,I), I = 1, 10) / + 1'Van Dooren 1981, Ex. II: singular R matrix', 'Ionescu/Weiss 1992 + 2: singular R matrix, nonzero S matrix', 'Jonckheere 1981: (A,B) co + 3ntrollable, no solution X <= 0', 'Sun 1998: R singular, Q non-defi + 4nite', 'Ackerson/Fu 1970 : satellite control problem', 'Litkouhi 1 + 5983 : system with slow and fast modes', 'Lu/Lin 1993, Ex. 4.3', 'G + 6ajic/Shen 1993, Section 2.7.4: chemical plant', 'Davison/Wang 1974 + 7: nonzero S matrix', 'Patnaik et al. 1980: tubular ammonia reactor + 8'/ + DATA (NOTES(1,I), I = 11, NEX1) / + 1'Sima 1996, Sec. 1.2.2: paper machine model error integrators', 'S + 2ima 1996, Ex. 2.6: paper machine model with with disturbances', 'P + 3ower plant model, Katayama et al., 1985'/ + DATA (NOTES(2,I), I = 1, NEX2) / + 1'Laub 1979, Ex. 2: uncontrollable-unobservable data', 'Laub 1979, + 2Ex. 3: increasingly ill-conditioned R-matrix', 'increasingly bad s + 3caled system as eps -> oo','Petkov et. al. 1989 : increasingly bad + 4 scaling as eps -> oo', 'Pappas et al. 1980: process control of pa + 5per machine'/ + DATA (NOTES(4,I), I = 1, NEX4) /'Pappas et al. 1980, Ex. 3'/ +C +C .. Executable Statements .. +C + INFO = 0 + DO 1 I = 1, 10 + VEC(I) = .FALSE. + 1 CONTINUE +C + IF (NR(1) .GE. 3) THEN + IF (LSAME(DEF, 'D')) IPAR(1) = NDEF(NR(1),NR(2)) + IPAR(2) = 1 + IPAR(3) = IPAR(1) + ELSE + IPAR(1) = NDEF(NR(1),NR(2)) + IPAR(2) = MDEF(NR(1),NR(2)) + IPAR(3) = PDEF(NR(1),NR(2)) + END IF +C + IF ((NR(1) .GE. 2) .AND. .NOT. ((LSAME(DEF,'D')) .OR. + $ (LSAME(DEF,'N')))) THEN + INFO = -1 + ELSE IF ((NR(1) .LT. 1) .OR. (NR(1) .GT. 4) .OR. (NR(2) .LT. 0) + 1 .OR. (NR(2) .GT. NEX(NR(1)))) THEN + INFO = -2 + ELSE IF (IPAR(1) .LT. 1) THEN + INFO = -4 + ELSE IF (IPAR(1) .GT. LDA) THEN + INFO = -12 + ELSE IF (IPAR(1) .GT. LDB) THEN + INFO = -14 + ELSE IF (IPAR(3) .GT. LDC) THEN + INFO = -16 + ELSE IF (BPAR(2) .AND. (((.NOT. BPAR(1)) .AND. + 1 (IPAR(3) .GT. LDQ)) .OR. (BPAR(1) .AND. + 2 (IPAR(1) .GT. LDQ)))) THEN + INFO = -18 + ELSE IF (BPAR(5) .AND. ((BPAR(4) .AND. (IPAR(1) .GT. LDR)) .OR. + 1 ((.NOT. BPAR(4)) .AND. (IPAR(2) .GT. LDR)))) THEN + INFO = -20 + ELSE IF (LDS .LT. 1 .OR. (BPAR(7) .AND. (IPAR(1) .GT. LDS))) THEN + INFO = -22 + ELSE IF (LDX .LT. 1) THEN + INFO = -24 + ELSE IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. + 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. + 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. + 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN +C .. solution X available .. + IF (IPAR(1) .GT. LDX) THEN + INFO = -24 + ELSE + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, X, LDX) + END IF + ELSE IF (LDWORK .LT. N*N) THEN + INFO = -26 + END IF + IF (INFO .NE. 0) THEN + CALL XERBLA( 'BB02AD', -INFO ) + RETURN + END IF +C + NSYMM = (IPAR(1)*(IPAR(1)+1))/2 + MSYMM = (IPAR(2)*(IPAR(2)+1))/2 + PSYMM = (IPAR(3)*(IPAR(3)+1))/2 +C + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ZERO, A, LDA) + CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, B, LDB) + CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ZERO, C, LDC) + CALL DLASET('L', PSYMM, 1, ZERO, ZERO, Q, 1) + CALL DLASET('L', MSYMM, 1, ZERO, ZERO, R, 1) + IF (BPAR(7)) CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ZERO, + 1 S, LDS) +C + IF(NR(1) .EQ. 1) THEN +C + IF (NR(2) .EQ. 1) THEN + A(1,1) = TWO + A(2,1) = ONE + A(1,2) = -ONE + B(1,1) = ONE + Q(1) = ONE + C(1,2) = ONE + R(1) = ZERO + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) + IDENT = '0000' +C + ELSE IF (NR(2) .EQ. 2) THEN + A(1,2) = ONE + A(2,2) = -ONE + B(1,1) = ONE + B(2,1) = TWO + B(2,2) = ONE + R(1) = 9.0D0 + R(2) = THREE + R(3) = ONE + CALL DLASET('A', PSYMM, 1, -FOUR, -FOUR, Q, PSYMM) + Q(3) = 7.0D0 + CALL DRSCL(MSYMM, 11.0D0, Q, 1) + IF (BPAR(7)) THEN + S(1,1) = THREE + S(2,1) = -ONE + S(1,2) = ONE + S(2,2) = 7.0D0 + END IF + IDENT = '0100' +C + ELSE IF (NR(2) .EQ. 3) THEN + A(1,2) = ONE + B(2,1) = ONE + Q(1) = ONE + Q(2) = TWO + Q(3) = FOUR + X(1,1) = ONE + X(2,1) = TWO + X(1,2) = TWO + X(2,2) = TWO + SQRT(FIVE) + IDENT = '0101' +C + ELSE IF (NR(2) .EQ. 4) THEN + A(1,2) = .1000D+00 + A(2,3) = .0100D+00 + B(1,1) = ONE + B(3,2) = ONE + R(3) = ONE + Q(1) = .1D+06 + Q(4) = .1D+04 + Q(6) = -.1D+02 + X(1,1) = .1D+06 + X(2,2) = .1D+04 + IDENT = '0100' +C + ELSE IF (((NR(2) .GE. 5) .AND. (NR(2) .LE. 8)) .OR. + 1 (NR(2) .EQ. 10) .OR. (NR(2) .EQ. 11) .OR. + 2 (NR(2) .EQ. 13)) THEN + IF (NR(2) .LT. 10) THEN + WRITE (CHPAR(1:11), '(A,I1,A,I1,A)') + 1 'BB02', NR(1), '0', NR(2), '.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) + ELSE + WRITE (CHPAR(1:11), '(A,I1,I2,A)') + 1 'BB02', NR(1), NR(2), '.dat' + OPEN(1, IOSTAT = IOS, STATUS = 'OLD', FILE = CHPAR(1:11)) + END IF + IF (IOS .NE. 0) THEN + INFO = 1 + ELSE + IF (.NOT. (NR(2) .EQ. 13)) THEN + DO 10 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) (A(I,J), J = 1, IPAR(1)) + IF (IOS .NE. 0) INFO = 1 + 10 CONTINUE + DO 20 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = IOS) (B(I,J), J = 1, IPAR(2)) + IF (IOS .NE. 0) INFO = 1 + 20 CONTINUE + END IF + IF (NR(2) .EQ. 5) THEN + Q(1) = .187D1 + Q(4) = -.244D0 + Q(5) = .744D0 + Q(6) = .205D0 + Q(8) = .589D0 + Q(10) = .1048D1 + ELSE IF (NR(2) .EQ. 6) THEN + Q(1) = .1D-1 + Q(5) = .1D-1 + Q(8) = .1D-1 + Q(10) = .1D-1 + ELSE IF (NR(2) .EQ. 7) THEN + CALL DLASET('U', IPAR(3), IPAR(1), ONE, ONE, C, LDC) + C(1,3) = TWO + C(1,4) = FOUR + C(2,4) = TWO + Q(1) = TWO + Q(2) = -ONE + Q(5) = TWO + Q(6) = -ONE + Q(8) = TWO + ELSE IF (NR(2) .EQ. 10) THEN + C(1,1) = ONE + C(2,5) = ONE + Q(1) = 50.0D0 + Q(3) = 50.0D0 + ELSE IF (NR(2) .EQ. 11) THEN + A(10,10) = ONE + A(11,11) = ONE + C(1,6) = 15.0D0 + C(2,7) = 7.0D0 + C(2,8) = -.5357D+01 + C(2,9) = -.3943D+01 + C(3,10) = ONE + C(4,11) = ONE + Q(1) = 0.5D0 + Q(5) = 5.0D0 + Q(8) = 0.5D0 + Q(10) = 5.0D0 + R(1) = 400.0D0 + R(3) = 700.0D0 + IDENT = '0000' +C + ELSE IF (NR(2) .EQ. 13) THEN + DO 24 I = 1, IPAR(1)-6 + READ (1, FMT = *, IOSTAT = IOS) + 1 (A(I,J), J = 1, IPAR(1)-6) + IF (IOS .NE. 0) INFO = 1 + 24 CONTINUE + DO 25 I = 1, IPAR(1)-6 + READ (1, FMT = *, IOSTAT = IOS) + 1 (B(I,J), J = 1, IPAR(2)) + IF (IOS .NE. 0) INFO = 1 + 25 CONTINUE + DO 26 I = 1, IPAR(2) + READ (1, FMT = *, IOSTAT = IOS) + 1 (C(I,J), J = 1, IPAR(1)-6) + IF (IOS .NE. 0) INFO = 1 + 26 CONTINUE + DO 27 I = 1, 6 + A(20+I,20+I) = ONE + C(6+I,20+I) = ONE + 27 CONTINUE + J = 58 + DO 28 I = 7, 12 + READ (1, FMT = *, IOSTAT = IOS) Q(J) + IF (IOS .NE. 0) INFO = 1 + J = J + (13 - I) + 28 CONTINUE + J = 1 + DO 29 I = 1, 6 + READ (1, FMT = *, IOSTAT = IOS) R(J) + IF (IOS .NE. 0) INFO = 1 + J = J + (7 - I) + 29 CONTINUE + DO 31 I = 1, 6 + DO 30 J = 1, 20 + A(I+20,J) = -C(I,J) + 30 CONTINUE + 31 CONTINUE + IDENT = '0000' + END IF + END IF + CLOSE(1) + IF ((NR(2) .EQ. 5) .OR. (NR(2) .EQ. 6)) THEN + IDENT = '0101' + ELSE IF ((NR(2) .EQ. 7) .OR. (NR(2) .EQ. 10)) THEN + IDENT = '0001' + ELSE IF (NR(2) .EQ. 8) THEN + IDENT = '0111' + END IF +C + ELSE IF (NR(2). EQ. 9) THEN + A(1,2) = ONE + A(2,3) = ONE + A(4,5) = ONE + A(5,6) = ONE + B(3,1) = ONE + B(6,2) = ONE + C(1,1) = ONE + C(1,2) = ONE + C(2,4) = ONE + C(2,5) = -ONE + R(1) = THREE + R(3) = ONE + IF (BPAR(7)) THEN + S(1,1) = ONE + S(2,1) = ONE + S(4,1) = ONE + S(5,1) = -ONE + END IF + IDENT = '0010' + ELSE IF (NR(2) .EQ. 12) THEN + DO 32 I = 1, 10 + A(I,I+1) = ONE + 32 CONTINUE + A(6,7) = ZERO + A(8,9) = ZERO + A(12,12) = ONE + A(13,13) = ONE + A(12,1) = -.3318D+01 + A(13,1) = -.15484D+01 + A(6,6) = .7788D+00 + A(8,7) = -.4724D+00 + A(13,7) = .3981D+00 + A(8,8) = .13746D+01 + A(13,8) = .5113D+00 + A(13,9) = .57865D+01 + A(11,11) = .8071D+00 + B(6,1) = ONE + B(8,2) = ONE + C(1,1) = .3318D+01 + C(2,1) = .15484D+01 + C(2,7) = -.3981D+00 + C(2,8) = -.5113D+00 + C(2,9) = -.57865D+01 + C(3,12) = ONE + C(4,13) = ONE + Q(1) = 0.5D0 + Q(5) = 5.0D0 + Q(8) = 0.5D0 + Q(10) = 5.0D0 + R(1) = 400.0D0 + R(3) = 700.0D0 + IDENT = '0000' + END IF +C + ELSE IF (NR(1) .EQ. 2) THEN + IF (NR(2) .EQ. 1) THEN + IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 + A(1,1) = FOUR + A(2,1) = -.45D1 + A(1,2) = THREE + A(2,2) = -.35D1 + CALL DLASET('A', IPAR(1), IPAR(2), -ONE, ONE, B, LDB) + R(1) = DPAR(1) + Q(1) = 9.0D0 + Q(2) = 6.0D0 + Q(3) = FOUR + TEMP = (ONE + SQRT(ONE+FOUR*DPAR(1))) / TWO + X(1,1) = TEMP*Q(1) + X(2,1) = TEMP*Q(2) + X(1,2) = X(2,1) + X(2,2) = TEMP*Q(3) + IDENT = '0100' +C + ELSE IF (NR(2) .EQ. 2) THEN + IF (LSAME(DEF, 'D')) DPAR(1) = .1D+07 + IF (DPAR(1) .EQ. ZERO) THEN + INFO = 2 + ELSE + A(1,1) = .9512D0 + A(2,2) = .9048D0 + CALL DLASET('A', 1, IPAR(2), .4877D1, .4877D1, B, LDB) + B(2,1) = -.11895D1 + B(2,2) = .3569D1 + R(1) = ONE / (THREE*DPAR(1)) + R(3) = THREE*DPAR(1) + Q(1) = .5D-2 + Q(3) = .2D-1 + IDENT = '0100' + END IF +C + ELSE IF (NR(2) .EQ. 3) THEN + IF (LSAME(DEF,'D')) DPAR(1) = .1D7 + A(1,2) = DPAR(1) + B(2,1) = ONE + X(1,1) = ONE + X(2,2) = ONE + DPAR(1)*DPAR(1) + IDENT = '0111' +C + ELSE IF (NR(2) .EQ. 4) THEN + IF (LSAME(DEF,'D')) DPAR(1) = .1D7 + A(2,2) = ONE + A(3,3) = THREE + R(1) = DPAR(1) + R(4) = DPAR(1) + R(6) = DPAR(1) +C .. set C = V .. + TEMP = TWO/THREE + CALL DLASET('A', IPAR(3), IPAR(1), -TEMP, ONE - TEMP, C, LDC) +C .. and compute A <- C' A C + CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, A, LDA, + 1 ZERO, DWORK, IPAR(1)) + CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, + 1 IPAR(1), ZERO, A, LDA) + Q(1) = DPAR(1) + Q(4) = DPAR(1) + Q(6) = DPAR(1) + X(1,1) = DPAR(1) + X(2,2) = DPAR(1) * (ONE + SQRT(FIVE)) / TWO + X(3,3) = DPAR(1) * (9.0D0 + SQRT(85.0D0)) / TWO + CALL DSYMM('L', 'L', IPAR(1), IPAR(1), ONE, C, LDC, X, LDX, + 1 ZERO, DWORK, IPAR(1)) + CALL DSYMM('R', 'L', IPAR(1), IPAR(1), ONE, C, LDC, DWORK, + 1 IPAR(1), ZERO, X, LDX) + IDENT = '1000' +C + ELSE IF (NR(2) .EQ. 5) THEN + IF (LSAME(DEF, 'D')) THEN + DPAR(4) = .25D0 + DPAR(3) = ONE + DPAR(2) = ONE + DPAR(1) = .1D9 + END IF + IF (DPAR(1) .EQ. ZERO) THEN + INFO = 2 + ELSE + TEMP = DPAR(2) / DPAR(1) + BETA = DPAR(3) * TEMP + ALPHA = ONE - TEMP + A(1,1) = ALPHA + CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(2,1), + 1 LDA) + B(1,1) = BETA + C(1,4) = ONE + R(1) = DPAR(4) + IF (BETA .EQ. ZERO) THEN + INFO = 2 + ELSE + CALL DLASET('A', IPAR(1), IPAR(1), ZERO, ONE, X, LDX) + BETA = BETA * BETA + TEMP = DPAR(4) * (ALPHA + ONE) * (ALPHA - ONE) + BETA + X(1,1) = (TEMP + SQRT(TEMP*TEMP + FOUR*BETA*DPAR(4))) + X(1,1) = X(1,1) / TWO / BETA + END IF + IDENT = '0010' + END IF + END IF +C + ELSE IF (NR(1) .EQ. 4) THEN + IF (NR(2) .EQ. 1) THEN + IF (LSAME(DEF,'D')) DPAR(1) = ONE + CALL DLASET('A', IPAR(1)-1, IPAR(1)-1, ZERO, ONE, A(1,2), LDA) + B(IPAR(1),1) = ONE + R(1) = DPAR(1) + DO 40 I = 1, IPAR(1) + X(I,I) = DBLE(I) + 40 CONTINUE + IDENT = '0110' + END IF + END IF +C + IF (INFO .NE. 0) GOTO 2001 +C .. set up data in required format .. +C + IF (BPAR(4)) THEN +C .. G is to be returned in product form .. + RDIMM = IPAR(1) + IF (IDENT(4:4) .EQ. '0') THEN +C .. invert R using Cholesky factorization, .. + CALL DPPTRF('L', IPAR(2), R, INFO) + IF (INFO .EQ. 0) THEN + CALL DPPTRI('L', IPAR(2), R, INFO) + IF (IDENT(1:1) .EQ. '0') THEN +C .. B is not identity matrix .. + DO 100 I = 1, IPAR(1) + CALL DSPMV('L', IPAR(2), ONE, R, B(I,1), LDB, ZERO, + 1 DWORK((I-1)*IPAR(1)+1), 1) + 100 CONTINUE + CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), + 1 B(1,1), LDB, ZERO, R, 1) + ISYMM = IPAR(1) + 1 + DO 110 I = 2, IPAR(1) + CALL DGEMV('T', IPAR(2), IPAR(1), ONE, DWORK, IPAR(1), + 1 B(I,1), LDB, ZERO, B(1,1), LDB) + CALL DCOPY(IPAR(1) - I + 1, B(1,I), LDB, R(ISYMM), 1) + ISYMM = ISYMM + (IPAR(1) - I + 1) + 110 CONTINUE + END IF + ELSE + IF (INFO .GT. 0) THEN + INFO = 3 + GOTO 2001 + END IF + END IF + ELSE +C .. R = identity .. + IF (IDENT(1:1) .EQ. '0') THEN +C .. B not identity matrix .. + IF (IPAR(2) .EQ. 1) THEN + CALL DLASET('L', NSYMM, 1, ZERO, ZERO, R, 1) + CALL DSPR('L', IPAR(1), ONE, B, 1, R) + ELSE + CALL DSYRK('L', 'N', IPAR(1), IPAR(2), ONE, B, LDB, ZERO, + 1 DWORK, IPAR(1)) + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), R) + END IF + ELSE +C .. B = R = identity .. + ISYMM = 1 + DO 120 I = IPAR(1), 1, -1 + R(ISYMM) = ONE + ISYMM = ISYMM + I + 120 CONTINUE + END IF + END IF + ELSE + RDIMM = IPAR(2) + IF (IDENT(1:1) .EQ. '1') + 1 CALL DLASET('A', IPAR(1), IPAR(2), ZERO, ONE, B, LDB) + IF (IDENT(4:4) .EQ. '1') THEN + ISYMM = 1 + DO 130 I = IPAR(2), 1, -1 + R(ISYMM) = ONE + ISYMM = ISYMM + I + 130 CONTINUE + END IF + END IF +C + IF (BPAR(1)) THEN +C .. Q is to be returned in product form .. + QDIMM = IPAR(1) + IF (IDENT(3:3) .EQ. '0') THEN + IF (IDENT(2:2) .EQ. '0') THEN +C .. C is not identity matrix .. + DO 140 I = 1, IPAR(1) + CALL DSPMV('L', IPAR(3), ONE, Q, C(1,I), 1, ZERO, + 1 DWORK((I-1)*IPAR(1)+1), 1) + 140 CONTINUE +C .. use Q(1:IPAR(1)) as workspace and compute the first column +C of Q at the end .. + ISYMM = IPAR(1) + 1 + DO 150 I = 2, IPAR(1) + CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), + 1 C(1,I), 1, ZERO, Q(1), 1) + CALL DCOPY(IPAR(1) - I + 1, Q(I), 1, Q(ISYMM), 1) + ISYMM = ISYMM + (IPAR(1) - I + 1) + 150 CONTINUE + CALL DGEMV('T', IPAR(3), IPAR(1), ONE, DWORK, IPAR(1), + 1 C(1,1), 1, ZERO, Q, 1) + END IF + ELSE +C .. Q = identity .. + IF (IDENT(2:2) .EQ. '0') THEN +C .. C is not identity matrix .. + IF (IPAR(3) .EQ. 1) THEN + CALL DLASET('L', NSYMM, 1, ZERO, ZERO, Q, 1) + CALL DSPR('L', IPAR(1), ONE, C, LDC, Q) + ELSE + CALL DSYRK('L', 'T', IPAR(1), IPAR(3), ONE, C, LDC, ZERO, + 1 DWORK, IPAR(1)) + CALL MA02DD('Pack', 'Lower', IPAR(1), DWORK, IPAR(1), Q) + END IF + ELSE +C .. C = Q = identity .. + ISYMM = 1 + DO 160 I = IPAR(1), 1, -1 + Q(ISYMM) = ONE + ISYMM = ISYMM + I + 160 CONTINUE + END IF + END IF + ELSE + QDIMM = IPAR(3) + IF (IDENT(2:2) .EQ. '1') + 1 CALL DLASET('A', IPAR(3), IPAR(1), ZERO, ONE, C, LDC) + IF (IDENT(3:3) .EQ. '1') THEN + ISYMM = 1 + DO 170 I = IPAR(3), 1, -1 + Q(ISYMM) = ONE + ISYMM = ISYMM + I + 170 CONTINUE + END IF + END IF +C +C .. unpack symmetric matrices if required .. + IF (BPAR(2)) THEN + ISYMM = (QDIMM * (QDIMM + 1)) / 2 + CALL DCOPY(ISYMM, Q, 1, DWORK, 1) + CALL MA02DD('Unpack', 'Lower', QDIMM, Q, LDQ, DWORK) + CALL MA02ED('Lower', QDIMM, Q, LDQ) + ELSE IF (BPAR(3)) THEN + CALL MA02DD('Unpack', 'Lower', QDIMM, DWORK, QDIMM, Q) + CALL MA02ED('Lower', QDIMM, DWORK, QDIMM) + CALL MA02DD('Pack', 'Upper', QDIMM, DWORK, QDIMM, Q) + END IF + IF (BPAR(5)) THEN + ISYMM = (RDIMM * (RDIMM + 1)) / 2 + CALL DCOPY(ISYMM, R, 1, DWORK, 1) + CALL MA02DD('Unpack', 'Lower', RDIMM, R, LDR, DWORK) + CALL MA02ED('Lower', RDIMM, R, LDR) + ELSE IF (BPAR(6)) THEN + CALL MA02DD('Unpack', 'Lower', RDIMM, DWORK, RDIMM, R) + CALL MA02ED('Lower', RDIMM, DWORK, RDIMM) + CALL MA02DD('Pack', 'Upper', RDIMM, DWORK, RDIMM, R) + END IF +C +C ...set VEC... + VEC(1) = .TRUE. + VEC(2) = .TRUE. + VEC(3) = .TRUE. + VEC(4) = .TRUE. + VEC(5) = .NOT. BPAR(4) + VEC(6) = .NOT. BPAR(1) + VEC(7) = .TRUE. + VEC(8) = .TRUE. + VEC(9) = BPAR(7) + IF (((NR(1) .EQ. 1) .AND. ((NR(2) .EQ. 1) .OR. + 1 (NR(2) .EQ. 3) .OR. (NR(2) .EQ. 4))) .OR. + 2 ((NR(1) .EQ. 2) .AND. ((NR(2). EQ. 1) .OR. + 3 (NR(2) .GE. 3))) .OR. (NR(1) .EQ. 4)) THEN + VEC(10) = .TRUE. + END IF + CHPAR = NOTES(NR(1),NR(2)) + N = IPAR(1) + M = IPAR(2) + P = IPAR(3) +C + 2001 CONTINUE + RETURN +C *** Last line of BB02AD *** + END diff --git a/mex/sources/libslicot/BB03AD.f b/mex/sources/libslicot/BB03AD.f new file mode 100644 index 000000000..d19c19105 --- /dev/null +++ b/mex/sources/libslicot/BB03AD.f @@ -0,0 +1,490 @@ + SUBROUTINE BB03AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, + 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, + 2 LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate benchmark examples of (generalized) continuous-time +C Lyapunov equations +C +C T T +C A X E + E X A = Y . +C +C In some examples, the right hand side has the form +C +C T +C Y = - B B +C +C and the solution can be represented as a product of Cholesky +C factors +C +C T +C X = U U . +C +C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note +C that E can be the identity matrix. For some examples, B, X, or U +C are not provided. +C +C This routine is an implementation of the benchmark library +C CTLEX (Version 1.0) described in [1]. +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER*1 +C Specifies the kind of values used as parameters when +C generating parameter-dependent and scalable examples +C (i.e., examples with NR(1) = 2, 3, or 4): +C DEF = 'D' or 'd': Default values are used. +C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. +C This parameter is not referenced if NR(1) = 1. +C Note that the scaling parameter of examples with +C NR(1) = 3 or 4 is considered as a regular parameter in +C this context. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension 2 +C Specifies the index of the desired example according +C to [1]. +C NR(1) defines the group: +C 1 : parameter-free problems of fixed size +C 2 : parameter-dependent problems of fixed size +C 3 : parameter-free problems of scalable size +C 4 : parameter-dependent problems of scalable size +C NR(2) defines the number of the benchmark example +C within a certain group according to [1]. +C +C DPAR (input/output) DOUBLE PRECISION array, dimension 2 +C On entry, if DEF = 'N' or 'n' and the desired example +C depends on real parameters, then the array DPAR must +C contain the values for these parameters. +C For an explanation of the parameters see [1]. +C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', +C respectively. +C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and +C 's', respectively. +C For Examples 4.3 and 4.4, DPAR(1) defines the parameter +C 't'. +C On exit, if DEF = 'D' or 'd' and the desired example +C depends on real parameters, then the array DPAR is +C overwritten by the default values given in [1]. +C +C IPAR (input/output) INTEGER array of DIMENSION at least 1 +C On entry, if DEF = 'N' or 'n' and the desired example +C depends on integer parameters, then the array IPAR must +C contain the values for these parameters. +C For an explanation of the parameters see [1]. +C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. +C For Example 4.4, IPAR(1) defines 'q'. +C On exit, if DEF = 'D' or 'd' and the desired example +C depends on integer parameters, then the array IPAR is +C overwritten by the default values given in [1]. +C +C VEC (output) LOGICAL array, dimension 8 +C Flag vector which displays the availability of the output +C data: +C VEC(1) and VEC(2) refer to N and M, respectively, and are +C always .TRUE. +C VEC(3) is .TRUE. iff E is NOT the identity matrix. +C VEC(4) and VEC(5) refer to A and Y, respectively, and are +C always .TRUE. +C VEC(6) is .TRUE. iff B is provided. +C VEC(7) is .TRUE. iff the solution matrix X is provided. +C VEC(8) is .TRUE. iff the Cholesky factor U is provided. +C +C N (output) INTEGER +C The actual state dimension, i.e., the order of the +C matrices E and A. +C +C M (output) INTEGER +C The number of rows in the matrix B. If B is not provided +C for the desired example, M = 0 is returned. +C +C E (output) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array contains the +C matrix E. +C NOTE that this array is overwritten (by the identity +C matrix), if VEC(3) = .FALSE. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= N. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the +C matrix Y. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,N) +C The leading M-by-N part of this array contains the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= M. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the +C matrix X. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= N. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C matrix U. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C NOTE (output) CHARACTER*70 +C String containing short information about the chosen +C example. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is +C required. +C For the other examples, no workspace is needed, i.e., +C LDWORK >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; in particular, INFO = -3 or -4 indicates +C that at least one of the parameters in DPAR or +C IPAR, respectively, has an illegal value. +C +C REFERENCES +C +C [1] D. Kressner, V. Mehrmann, and T. Penzl. +C CTLEX - a Collection of Benchmark Examples for Continuous- +C Time Lyapunov Equations. +C SLICOT Working Note 1999-6, 1999. +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) +C +C For questions concerning the collection or for the submission of +C test examples, please contact Volker Mehrmann +C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). +C +C REVISIONS +C +C June 1999, V. Sima. +C +C KEYWORDS +C +C continuous-time Lyapunov equations +C +C ******************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR + PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, + 1 THREE = .3D1, FOUR = .4D1) +C .. Scalar Arguments .. + CHARACTER DEF + CHARACTER*70 NOTE + INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N +C .. Array Arguments .. + LOGICAL VEC(8) + INTEGER IPAR(*), NR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), + 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) +C .. Local Scalars .. + INTEGER I, J, K + DOUBLE PRECISION TEMP, TTM1, TTP1, TWOBYN +C .. Local Arrays .. + LOGICAL VECDEF(8) +C .. External Functions .. +C . BLAS . + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. +C . BLAS . + EXTERNAL DGEMV, DGER, DAXPY +C . LAPACK . + EXTERNAL DLASET +C .. Intrinsic Functions .. + INTRINSIC DBLE, MIN, MOD +C .. Data Statements .. +C . default values for availabilities . + DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., + 1 .TRUE., .FALSE., .FALSE., .FALSE./ +C +C .. Executable Statements .. +C + INFO = 0 + DO 10 I = 1, 8 + VEC(I) = VECDEF(I) + 10 CONTINUE +C + IF (NR(1) .EQ. 4) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'CTLEX: Example 4.1' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .15D1 + DPAR(2) = .15D1 + END IF + IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (LDX .LT. N) INFO = -17 + IF (LDWORK .LT. N*2) INFO = -22 + IF (INFO .NE. 0) RETURN +C + VEC(6) = .TRUE. + VEC(7) = .TRUE. + TWOBYN = TWO / DBLE( N ) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) + CALL DLASET('A', M, N, ZERO, ZERO, B, LDB) + CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) + DO 30 J = 1, N + TEMP = DPAR(1) ** (J-1) + A(J,J) = -TEMP + DWORK(J) = ONE + DO 20 I = 1, N + X(I,J) = DBLE( I*J ) / (TEMP + DPAR(1)**(I-1)) + 20 CONTINUE + 30 CONTINUE +C H1 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H1 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C H1 * X + CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) +C X * H1 + CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) +C S A INV(S), INV(S) X INV(S), B INV(S) + DO 50 J = 1, N + B(1,J) = DBLE( J-N-1 ) / (DPAR(2)**(J-1)) + DO 40 I = 1, N + X(I,J) = X(I,J) / (DPAR(2)**(I+J-2)) + A(I,J) = A(I,J) * (DPAR(2)**(I-J)) + 40 CONTINUE + DWORK(J) = ONE - TWO * MOD(J,2) + 50 CONTINUE +C H2 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H2 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C H2 * X + CALL DGEMV('T', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, X, LDX) +C X * H2 + CALL DGEMV('N', N,N, ONE, X, LDX, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, X, LDX) +C B * H2 + CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, + 1 B, LDB) +C Y = -B' * B + CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'CTLEX: Example 4.2' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = -.5D0 + DPAR(2) = .15D1 + END IF + IF ((DPAR(1) .GE. ZERO) .OR. (DPAR(2) .LE. ONE)) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (LDWORK .LT. N*2) INFO = -22 + IF (INFO .NE. 0) RETURN +C + VEC(6) = .TRUE. + TWOBYN = TWO / DBLE( N ) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) + CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) + CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) + DO 60 I = 1, N-1 + DWORK(I) = ONE + A(I,I+1) = ONE + 60 CONTINUE + DWORK(N) = ONE +C H1 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H1 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C S A INV(S), B INV(S) + DO 80 J = 1, N + B(1,J) = B(1,J) / (DPAR(2)**(J-1)) + DO 70 I = 1, N + A(I,J) = A(I,J) * (DPAR(2)**(I-J)) + 70 CONTINUE + DWORK(J) = ONE - TWO * MOD(J,2) + 80 CONTINUE +C H2 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H2 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C B * H2 + CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, + 1 B, LDB) +C Y = -B' * B + CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'CTLEX: Example 4.3' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .1D2 + END IF + IF (DPAR(1) .LT. ZERO) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 0 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDX .LT. N) INFO = -17 + IF (INFO .NE. 0) RETURN +C + VEC(3) = .TRUE. + VEC(7) = .TRUE. + TEMP = TWO ** (-DPAR(1)) + CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) + CALL DLASET('L', N, N, TEMP, ONE, E, LDE) + CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('U', N, N, ONE, ZERO, A, LDA) + CALL DLASET('A', N, N, ONE, ONE, X, LDX) + DO 90 I = 1, N + A(I,I) = DBLE( I - 1 ) + TEMP + 90 CONTINUE + Y(1,1) = TWO * TEMP + TWO * DBLE( N-1 ) * TEMP**2 + TTP1 = TWO * DBLE( N+1 ) * TEMP + TWO - TEMP**2 + TTM1 = TWO * DBLE( N-1 ) * TEMP + TWO - TEMP**2 + DO 100 I = 2, N + Y(I,1) = Y(1,1) + DBLE( I-1 ) * TTM1 + 100 CONTINUE + DO 120 J = 2, N + DO 110 I = 1, N + Y(I,J) = Y(I,1) + DBLE( J-1 ) * (TTP1 - FOUR * I * TEMP) + 110 CONTINUE + 120 CONTINUE +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'CTLEX: Example 4.4' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .15D1 + END IF + IF (DPAR(1) .LT. ONE) INFO = -3 + IF (IPAR(1) .LT. 1) INFO = -4 + N = IPAR(1) * 3 + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (INFO .NE. 0) RETURN +C + VEC(3) = .TRUE. + VEC(6) = .TRUE. + CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + DO 150 I = 1, IPAR(1) + TEMP = -DPAR(1)**I + DO 140 J = 1, I - 1 + DO 130 K = 0, 2 + A(N - I*3+3, J*3-K) = TEMP + A(N - I*3+2, J*3-K) = TWO * TEMP + 130 CONTINUE + 140 CONTINUE + A(N - I*3+3, I*3-2) = TEMP + A(N - I*3+2, I*3-2) = TWO * TEMP + A(N - I*3+2, I*3-1) = TWO * TEMP + A(N - I*3+2, I*3 ) = TEMP + A(N - I*3+1, I*3 ) = TEMP + 150 CONTINUE + DO 170 J = 1, N + IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) + B(1, J) = DBLE( J ) + DO 160 I = 1, N + E(I,N-J+1) = DBLE( MIN( I, J ) ) + Y(I,J) = -DBLE( I*J ) + 160 CONTINUE + 170 CONTINUE +C + ELSE + INFO = -2 + END IF + ELSE + INFO = -2 + END IF +C + RETURN +C *** Last Line of BB03AD *** + END diff --git a/mex/sources/libslicot/BB04AD.f b/mex/sources/libslicot/BB04AD.f new file mode 100644 index 000000000..a017a8808 --- /dev/null +++ b/mex/sources/libslicot/BB04AD.f @@ -0,0 +1,476 @@ + SUBROUTINE BB04AD(DEF, NR, DPAR, IPAR, VEC, N, M, E, LDE, A, LDA, + 1 Y, LDY, B, LDB, X, LDX, U, LDU, NOTE, DWORK, + 2 LDWORK, INFO) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate benchmark examples of (generalized) discrete-time +C Lyapunov equations +C +C T T +C A X A - E X E = Y . +C +C In some examples, the right hand side has the form +C +C T +C Y = - B B +C +C and the solution can be represented as a product of Cholesky +C factors +C +C T +C X = U U . +C +C E, A, Y, X, and U are real N-by-N matrices, and B is M-by-N. Note +C that E can be the identity matrix. For some examples, B, X, or U +C are not provided. +C +C This routine is an implementation of the benchmark library +C DTLEX (Version 1.0) described in [1]. +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER*1 +C Specifies the kind of values used as parameters when +C generating parameter-dependent and scalable examples +C (i.e., examples with NR(1) = 2, 3, or 4): +C DEF = 'D' or 'd': Default values are used. +C DEF = 'N' or 'n': Values set in DPAR and IPAR are used. +C This parameter is not referenced if NR(1) = 1. +C Note that the scaling parameter of examples with +C NR(1) = 3 or 4 is considered as a regular parameter in +C this context. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension 2 +C Specifies the index of the desired example according +C to [1]. +C NR(1) defines the group: +C 1 : parameter-free problems of fixed size +C 2 : parameter-dependent problems of fixed size +C 3 : parameter-free problems of scalable size +C 4 : parameter-dependent problems of scalable size +C NR(2) defines the number of the benchmark example +C within a certain group according to [1]. +C +C DPAR (input/output) DOUBLE PRECISION array, dimension 2 +C On entry, if DEF = 'N' or 'n' and the desired example +C depends on real parameters, then the array DPAR must +C contain the values for these parameters. +C For an explanation of the parameters see [1]. +C For Example 4.1, DPAR(1) and DPAR(2) define 'r' and 's', +C respectively. +C For Example 4.2, DPAR(1) and DPAR(2) define 'lambda' and +C 's', respectively. +C For Examples 4.3 and 4.4, DPAR(1) defines the parameter +C 't'. +C On exit, if DEF = 'D' or 'd' and the desired example +C depends on real parameters, then the array DPAR is +C overwritten by the default values given in [1]. +C +C IPAR (input/output) INTEGER array of DIMENSION at least 1 +C On entry, if DEF = 'N' or 'n' and the desired example +C depends on integer parameters, then the array IPAR must +C contain the values for these parameters. +C For an explanation of the parameters see [1]. +C For Examples 4.1, 4.2, and 4.3, IPAR(1) defines 'n'. +C For Example 4.4, IPAR(1) defines 'q'. +C On exit, if DEF = 'D' or 'd' and the desired example +C depends on integer parameters, then the array IPAR is +C overwritten by the default values given in [1]. +C +C VEC (output) LOGICAL array, dimension 8 +C Flag vector which displays the availability of the output +C data: +C VEC(1) and VEC(2) refer to N and M, respectively, and are +C always .TRUE. +C VEC(3) is .TRUE. iff E is NOT the identity matrix. +C VEC(4) and VEC(5) refer to A and Y, respectively, and are +C always .TRUE. +C VEC(6) is .TRUE. iff B is provided. +C VEC(7) is .TRUE. iff the solution matrix X is provided. +C VEC(8) is .TRUE. iff the Cholesky factor U is provided. +C +C N (output) INTEGER +C The actual state dimension, i.e., the order of the +C matrices E and A. +C +C M (output) INTEGER +C The number of rows in the matrix B. If B is not provided +C for the desired example, M = 0 is returned. +C +C E (output) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array contains the +C matrix E. +C NOTE that this array is overwritten (by the identity +C matrix), if VEC(3) = .FALSE. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= N. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the +C matrix Y. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,N) +C The leading M-by-N part of this array contains the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= M. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the +C matrix X. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= N. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C matrix U. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C NOTE (output) CHARACTER*70 +C String containing short information about the chosen +C example. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C For Examples 4.1 and 4.2., LDWORK >= 2*IPAR(1) is +C required. +C For the other examples, no workspace is needed, i.e., +C LDWORK >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; in particular, INFO = -3 or -4 indicates +C that at least one of the parameters in DPAR or +C IPAR, respectively, has an illegal value. +C +C REFERENCES +C +C [1] D. Kressner, V. Mehrmann, and T. Penzl. +C DTLEX - a Collection of Benchmark Examples for Discrete- +C Time Lyapunov Equations. +C SLICOT Working Note 1999-7, 1999. +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) +C +C For questions concerning the collection or for the submission of +C test examples, please contact Volker Mehrmann +C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). +C +C REVISIONS +C +C June 1999, V. Sima. +C +C KEYWORDS +C +C discrete-time Lyapunov equations +C +C ******************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR + PARAMETER (ZERO = .0D0, ONE = .1D1, TWO = .2D1, + 1 THREE = .3D1, FOUR = .4D1) +C .. Scalar Arguments .. + CHARACTER DEF + CHARACTER*70 NOTE + INTEGER INFO, LDA, LDB, LDE, LDU, LDWORK, LDX, LDY, M, N +C .. Array Arguments .. + LOGICAL VEC(8) + INTEGER IPAR(*), NR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DPAR(*), DWORK(LDWORK), + 1 E(LDE,*), U(LDU,*), X(LDX,*), Y(LDY,*) +C .. Local Scalars .. + INTEGER I, J, K + DOUBLE PRECISION TEMP, TTEMP, TWOBYN +C .. Local Arrays .. + LOGICAL VECDEF(8) +C .. External Functions .. +C . BLAS . + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. +C . BLAS . + EXTERNAL DGEMV, DGER, DAXPY +C . LAPACK . + EXTERNAL DLASET +C .. Intrinsic Functions .. + INTRINSIC DBLE, MIN, MOD, SQRT +C .. Data Statements .. +C . default values for availabilities . + DATA VECDEF /.TRUE., .TRUE., .FALSE., .TRUE., + 1 .TRUE., .FALSE., .FALSE., .FALSE./ +C +C .. Executable Statements .. +C + INFO = 0 + DO 10 I = 1, 8 + VEC(I) = VECDEF(I) + 10 CONTINUE +C + IF (NR(1) .EQ. 4) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'DTLEX: Example 4.1' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .15D1 + DPAR(2) = .15D1 + END IF + IF ((DPAR(1) .LE. ONE) .OR. (DPAR(2) .LE. ONE)) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (LDX .LT. N) INFO = -17 + IF (LDWORK .LT. N*2) INFO = -22 + IF (INFO .NE. 0) RETURN +C + VEC(6) = .TRUE. + VEC(7) = .TRUE. + TWOBYN = TWO / DBLE( N ) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) + CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) + CALL DLASET('A', N, N, ZERO, ZERO, X, LDX) + DO 20 I = 1, N + TEMP = DPAR(1) ** (I-1) + A(I,I) = (TEMP-ONE) / (TEMP+ONE) + DWORK(I) = ONE + 20 CONTINUE +C H1 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H1 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C S A INV(S), B INV(S) + DO 40 J = 1, N + B(1,J) = B(1,J) / (DPAR(2)**(J-1)) + DO 30 I = 1, N + A(I,J) = A(I,J) * (DPAR(2)**(I-J)) + 30 CONTINUE + DWORK(J) = ONE - TWO * MOD(J,2) + 40 CONTINUE +C H2 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H2 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C B * H2 + CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, + 1 B, LDB) +C Y = -B' * B + CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) +C X = -Y + DO 50 J = 1, N + CALL DAXPY(N, -ONE, Y(1,J), 1, X(1,J), 1) + 50 CONTINUE +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'DTLEX: Example 4.2' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = -.5D0 + DPAR(2) = .15D1 + END IF + IF ((DPAR(1) .LE. -ONE) .OR. (DPAR(1) .GE. ONE) .OR. + 1 (DPAR(2) .LE. ONE)) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (LDWORK .LT. N*2) INFO = -22 + IF (INFO .NE. 0) RETURN +C + VEC(6) = .TRUE. + TWOBYN = TWO / DBLE( N ) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) + CALL DLASET('A', N, N, ZERO, ZERO, Y, LDY) + CALL DLASET('A', M, N, -TWOBYN, ONE - TWOBYN, B, LDB) + DO 60 I = 1, N-1 + DWORK(I) = ONE + A(I,I+1) = ONE + 60 CONTINUE + DWORK(N) = ONE +C H1 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H1 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C S A INV(S), B INV(S) + DO 80 J = 1, N + B(1,J) = B(1,J) / (DPAR(2)**(J-1)) + DO 70 I = 1, N + A(I,J) = A(I,J) * (DPAR(2)**(I-J)) + 70 CONTINUE + DWORK(J) = ONE - TWO * MOD(J,2) + 80 CONTINUE +C H2 * A + CALL DGEMV('T', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK, 1, DWORK(N+1), 1, A, LDA) +C A * H2 + CALL DGEMV('N', N,N, ONE, A, LDA, DWORK,1, ZERO, DWORK(N+1),1) + CALL DGER(N, N, -TWOBYN, DWORK(N+1), 1, DWORK, 1, A, LDA) +C B * H2 + CALL DAXPY(N, -TWOBYN * DDOT(N, B, LDB, DWORK, 1), DWORK, 1, + 1 B, LDB) +C Y = -B' * B + CALL DGER(N ,N, -ONE, B, LDB, B, LDB, Y, LDY) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'DTLEX: Example 4.3' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .1D2 + END IF + IF (DPAR(1) .LT. ZERO) INFO = -3 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 0 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDX .LT. N) INFO = -17 + IF (INFO .NE. 0) RETURN +C + VEC(3) = .TRUE. + VEC(7) = .TRUE. + TEMP = TWO ** (-DPAR(1)) + CALL DLASET('U', N, N, ZERO, ZERO, E, LDE) + CALL DLASET('L', N, N, TEMP, ONE, E, LDE) + CALL DLASET('L', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('U', N, N, ONE, ZERO, A, LDA) + CALL DLASET('A', N, N, ONE, ONE, X, LDX) + DO 90 I = 1, N + A(I,I) = DBLE( I ) + TEMP + 90 CONTINUE + DO 110 J = 1, N + DO 100 I = 1, N + Y(I,J) = TEMP * TEMP * DBLE( 1 - (N-I) * (N-J) ) + + 1 TEMP * DBLE( 3 * (I+J) - 2 * (N+1) ) + + 2 FOUR*DBLE( I*J ) - TWO * DBLE( I+J ) + 100 CONTINUE + 110 CONTINUE +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'DTLEX: Example 4.4' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 10 + DPAR(1) = .15D1 + END IF + IF (DPAR(1) .LT. ONE) INFO = -3 + IF (IPAR(1) .LT. 1) INFO = -4 + N = IPAR(1) * 3 + M = 1 + IF (LDE .LT. N) INFO = -9 + IF (LDA .LT. N) INFO = -11 + IF (LDY .LT. N) INFO = -13 + IF (LDB .LT. M) INFO = -15 + IF (INFO .NE. 0) RETURN +C + VEC(3) = .TRUE. + VEC(6) = .TRUE. + CALL DLASET('A', N, N, ZERO, ZERO, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + DO 140 I = 1, IPAR(1) + TTEMP = ONE - ONE / (DPAR(1)**I) + TEMP = - TTEMP / SQRT( TWO ) + DO 130 J = 1, I - 1 + DO 120 K = 0, 2 + A(N - I*3+3, J*3-K) = TTEMP + A(N - I*3+2, J*3-K) = TWO * TEMP + 120 CONTINUE + 130 CONTINUE + A(N - I*3+3, I*3-2) = TTEMP + A(N - I*3+2, I*3-2) = TWO * TEMP + A(N - I*3+2, I*3-1) = TWO * TEMP + A(N - I*3+2, I*3 ) = TEMP + A(N - I*3+1, I*3 ) = TEMP + 140 CONTINUE + DO 160 J = 1, N + IF (J .GT. 1) CALL DAXPY(N, ONE, A(J-1,1), LDA, A(J,1), LDA) + B(1, J) = DBLE( J ) + DO 150 I = 1, N + E(I,N-J+1) = DBLE( MIN(I,J) ) + Y(I,J) = -DBLE( I*J ) + 150 CONTINUE + 160 CONTINUE +C + ELSE + INFO = -2 + END IF + ELSE + INFO = -2 + END IF +C + RETURN +C *** Last Line of BB04AD *** + END diff --git a/mex/sources/libslicot/BD01AD.f b/mex/sources/libslicot/BD01AD.f new file mode 100644 index 000000000..9cc34c065 --- /dev/null +++ b/mex/sources/libslicot/BD01AD.f @@ -0,0 +1,1017 @@ + SUBROUTINE BD01AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, + 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, + 2 LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate benchmark examples for time-invariant, +C continuous-time dynamical systems +C +C . +C E x(t) = A x(t) + B u(t) +C +C y(t) = C x(t) + D u(t) +C +C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and +C D is P-by-M. In many examples, E is the identity matrix and D is +C the zero matrix. +C +C This routine is an implementation of the benchmark library +C CTDSX (Version 1.0) described in [1]. +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER*1 +C Specifies the kind of values used as parameters when +C generating parameter-dependent and scalable examples +C (i.e., examples with NR(1) = 2, 3, or 4): +C = 'D': Default values defined in [1] are used; +C = 'N': Values set in DPAR and IPAR are used. +C This parameter is not referenced if NR(1) = 1. +C Note that the scaling parameter of examples with +C NR(1) = 3 or 4 is considered as a regular parameter in +C this context. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension (2) +C Specifies the index of the desired example according +C to [1]. +C NR(1) defines the group: +C 1 : parameter-free problems of fixed size +C 2 : parameter-dependent problems of fixed size +C 3 : parameter-free problems of scalable size +C 4 : parameter-dependent problems of scalable size +C NR(2) defines the number of the benchmark example +C within a certain group according to [1]. +C +C DPAR (input/output) DOUBLE PRECISION array, dimension (7) +C On entry, if DEF = 'N' and the desired example depends on +C real parameters, then the array DPAR must contain the +C values for these parameters. +C For an explanation of the parameters see [1]. +C For Examples 2.1 and 2.2, DPAR(1) defines the parameter +C 'epsilon'. +C For Example 2.4, DPAR(1), ..., DPAR(7) define 'b', 'mu', +C 'r', 'r_c', 'k_l', 'sigma', 'a', respectively. +C For Example 2.7, DPAR(1) and DPAR(2) define 'mu' and 'nu', +C respectively. +C For Example 4.1, DPAR(1), ..., DPAR(7) define 'a', 'b', +C 'c', 'beta_1', 'beta_2', 'gamma_1', 'gamma_2', +C respectively. +C For Example 4.2, DPAR(1), ..., DPAR(3) define 'mu', +C 'delta', 'kappa', respectively. +C On exit, if DEF = 'D' and the desired example depends on +C real parameters, then the array DPAR is overwritten by the +C default values given in [1]. +C +C IPAR (input/output) INTEGER array, dimension (1) +C On entry, if DEF = 'N' and the desired example depends on +C integer parameters, then the array IPAR must contain the +C values for these parameters. +C For an explanation of the parameters see [1]. +C For Examples 2.3, 2.5, and 2.6, IPAR(1) defines the +C parameter 's'. +C For Example 3.1, IPAR(1) defines 'q'. +C For Examples 3.2 and 3.3, IPAR(1) defines 'n'. +C For Example 3.4, IPAR(1) defines 'l'. +C For Example 4.1, IPAR(1) defines 'n'. +C For Example 4.2, IPAR(1) defines 'l'. +C On exit, if DEF = 'D' and the desired example depends on +C integer parameters, then the array IPAR is overwritten by +C the default values given in [1]. +C +C VEC (output) LOGICAL array, dimension (8) +C Flag vector which displays the availabilty of the output +C data: +C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, +C and are always .TRUE.. +C VEC(4) is .TRUE. iff E is NOT the identity matrix. +C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, +C and are always .TRUE.. +C VEC(8) is .TRUE. iff D is NOT the zero matrix. +C +C N (output) INTEGER +C The actual state dimension, i.e., the order of the +C matrices E and A. +C +C M (output) INTEGER +C The number of columns in the matrices B and D. +C +C P (output) INTEGER +C The number of rows in the matrices C and D. +C +C E (output) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array contains the +C matrix E. +C NOTE that this array is overwritten (by the identity +C matrix), if VEC(4) = .FALSE.. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= N. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array contains the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array contains the +C matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= P. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array contains the +C matrix D. +C NOTE that this array is overwritten (by the zero +C matrix), if VEC(8) = .FALSE.. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= P. +C +C NOTE (output) CHARACTER*70 +C String containing short information about the chosen +C example. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C For Example 3.4, LDWORK >= 4*IPAR(1) is required. +C For the other examples, no workspace is needed, i.e., +C LDWORK >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; in particular, INFO = -3 or -4 indicates +C that at least one of the parameters in DPAR or +C IPAR, respectively, has an illegal value; +C = 1: data file can not be opened or has wrong format. +C +C +C REFERENCES +C +C [1] Kressner, D., Mehrmann, V. and Penzl, T. +C CTDSX - a Collection of Benchmark Examples for State-Space +C Realizations of Continuous-Time Dynamical Systems. +C SLICOT Working Note 1998-9. 1998. +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) +C +C For questions concerning the collection or for the submission of +C test examples, please contact Volker Mehrmann +C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). +C +C REVISIONS +C +C June 1999, V. Sima. +C +C KEYWORDS +C +C continuous-time dynamical systems +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + 1 THREE = 3.0D0, FOUR = 4.0D0, + 2 PI = .3141592653589793D1 ) +C .. Scalar Arguments .. + CHARACTER DEF + CHARACTER*70 NOTE + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P +C .. Array Arguments .. + LOGICAL VEC(8) + INTEGER IPAR(*), NR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), + 1 DWORK(*), E(LDE,*) +C .. Local Scalars .. + CHARACTER*12 DATAF + INTEGER I, J, L, STATUS + DOUBLE PRECISION APPIND, B1, B2, C1, C2, TEMP, TTEMP +C .. Local Arrays .. + LOGICAL VECDEF(8) +C .. External Functions .. +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. +C . BLAS . + EXTERNAL DSCAL +C . LAPACK . + EXTERNAL DLASET +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +C .. Data Statements .. +C . default values for availabities . + DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., + 1 .TRUE., .TRUE., .TRUE., .FALSE./ +C +C .. Executable Statements .. +C + INFO = 0 + DO 10 I = 1, 8 + VEC(I) = VECDEF(I) +10 CONTINUE +C + IF (NR(1) .EQ. 1) THEN +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Laub 1979, Ex.1' + N = 2 + M = 1 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + B(1,1) = ZERO + B(2,1) = ONE + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Laub 1979, Ex.2: uncontrollable-unobservable data' + N = 2 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + A(1,1) = FOUR + A(2,1) = -.45D1 + A(1,2) = .3D1 + A(2,2) = -.35D1 + B(1,1) = ONE + B(2,1) = -ONE + C(1,1) = THREE + C(1,2) = TWO + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'Beale/Shafai 1989: model of L-1011 aircraft' + N = 4 + M = 2 + P = 4 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'Bhattacharyya et al. 1983: binary distillation column' + N = 8 + M = 2 + P = 8 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 5) THEN + NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' + N = 9 + M = 3 + P = 9 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 6) THEN + NOTE = 'Davison/Gesing 1978: J-100 jet engine' + N = 30 + M = 3 + P = 5 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 7) THEN + NOTE = 'Davison 1967: binary distillation column' + N = 11 + M = 3 + P = 3 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(2,1) = ONE + C(1,10) = ONE + C(3,11) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) + + ELSE IF (NR(2) .EQ. 8) THEN + NOTE = 'Chien/Ergin/Ling/Lee 1958: drum boiler' + N = 9 + M = 3 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,6) = ONE + C(2,9) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 9) THEN + NOTE = 'Ly, Gangsaas 1981: B-767 airplane' + N = 55 + M = 2 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 10) THEN + NOTE = 'control surface servo for an underwater vehicle' + N = 8 + M = 2 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,7) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) + ELSE + INFO = -2 + END IF +C + IF ((NR(2) .GE. 3) .AND. (NR(2) .LE. 10)) THEN +C .. loading data files + WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD011', NR(2), '.dat' + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 110 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +110 CONTINUE + DO 120 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) + IF (STATUS .NE. 0) INFO = 1 +120 CONTINUE + IF ((NR(2) .EQ. 6) .OR. (NR(2) .EQ. 9)) THEN + DO 130 I = 1, P + READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +130 CONTINUE + END IF + END IF + CLOSE(1) + END IF +C + ELSE IF (NR(1) .EQ. 2) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Chow/Kokotovic 1976: magnetic tape control system' + IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 + IF (DPAR(1) .EQ. ZERO) INFO = -3 + N = 4 + M = 1 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = .400D0 + A(2,3) = .345D0 + A(3,2) = -.524D0/DPAR(1) + A(3,3) = -.465D0/DPAR(1) + A(3,4) = .262D0/DPAR(1) + A(4,4) = -ONE/DPAR(1) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(4,1) = ONE/DPAR(1) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + C(2,3) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Arnold/Laub 1984' + IF (LSAME(DEF,'D')) DPAR(1) = 1D-6 + N = 4 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, DPAR(1), A, LDA) + A(1,1) = -DPAR(1) + A(2,1) = -ONE + A(1,2) = ONE + A(2,2) = -DPAR(1) + A(4,3) = -ONE + A(3,4) = ONE + CALL DLASET('A', N, M, ONE, ONE, B, LDB) + CALL DLASET('A', P, N, ONE, ONE, C, LDC) + D(1,1) = ZERO +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'Vertical acceleration of a rigid guided missile' + IF (LSAME(DEF,'D')) IPAR(1) = 1 + IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 10)) INFO = -4 + N = 3 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(2,1) = ONE + A(3,3) = -.19D3 + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(3,1) = .19D3 + D(1,1) = ZERO + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01203.dat') + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 210 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 + READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 2, N) + IF (STATUS .NE. 0) INFO = 1 + READ (1, FMT = *, IOSTAT = STATUS) (C(1,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +210 CONTINUE + END IF + CLOSE(1) +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'Senning 1980: hydraulic positioning system' + IF (LSAME(DEF,'D')) THEN + DPAR(1) = .14D5 + DPAR(2) = .1287D0 + DPAR(3) = .15D0 + DPAR(4) = .1D-1 + DPAR(5) = .2D-2 + DPAR(6) = .24D0 + DPAR(7) = .1075D2 + END IF + IF (((DPAR(1) .LE. .9D4) .OR. (DPAR(1) .GE. .16D5)) .OR. + 1 ((DPAR(2) .LE. .5D-1) .OR. (DPAR(2) .GE. .3D0)) .OR. + 2 ((DPAR(3) .LE. .5D-1) .OR. (DPAR(3) .GE. .5D1)) .OR. + 3 ((DPAR(4) .LE. ZERO) .OR. (DPAR(4) .GE. .5D-1)) .OR. + 4 ((DPAR(5) .LE. .103D-3) .OR. (DPAR(5) .GE. .35D-2)) .OR. + 5 ((DPAR(6) .LE. .1D-2) .OR. (DPAR(6) .GE. .15D2)) .OR. + 6 ((DPAR(7) .LE. .105D2) .OR. (DPAR(7) .GE. .111D2))) THEN + INFO = -3 + END IF + N = 3 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + A(2,2) = -(DPAR(3) + FOUR*DPAR(4)/PI) / DPAR(2) + A(2,3) = DPAR(7) / DPAR(2) + A(3,2) = -FOUR * DPAR(7) * DPAR(1) / .874D3 + A(3,3) = -FOUR * DPAR(1) * (DPAR(6) + DPAR(5)) / .874D3 + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(3,1) = -FOUR * DPAR(1) / .874D3 + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + D(1,1) = 0 +C + ELSE IF (NR(2) .EQ. 5) THEN + NOTE = 'Kwakernaak/Westdyk 1985: cascade of inverted pendula' + IF (LSAME(DEF,'D')) IPAR(1) = 1 + IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 7)) INFO = -4 + IF (IPAR(1) .LE. 6) THEN + M = IPAR(1) + ELSE + M = 10 + END IF + N = 2 * M + P = M + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + WRITE (DATAF(1:12), '(A,I1,A)') 'BD01205', IPAR(1), '.dat' + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:12)) + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 220 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +220 CONTINUE + DO 230 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) + IF (STATUS .NE. 0) INFO = 1 +230 CONTINUE + DO 240 I = 1, P + READ (1, FMT = *, IOSTAT = STATUS) (C(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +240 CONTINUE + END IF + CLOSE(1) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 6) THEN + NOTE = 'Kallstrom/Astrom 1981: regulation of a ship heading' + IF (LSAME(DEF,'D')) IPAR(1) = 1 + IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 5)) INFO = -4 + N = 3 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(3,2) = ONE + B(3,1) = ZERO + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,3) = ONE + D(1,1) = ZERO + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01206.dat') + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 250 I = 1, IPAR(1) + READ (1, FMT = *, IOSTAT = STATUS) (A(1,J), J = 1, 2) + IF (STATUS .NE. 0) INFO = 1 + READ (1, FMT = *, IOSTAT = STATUS) (A(2,J), J = 1, 2) + IF (STATUS .NE. 0) INFO = 1 + READ (1, FMT = *, IOSTAT = STATUS) (B(J,1), J = 1, 2) + IF (STATUS .NE. 0) INFO = 1 +250 CONTINUE + END IF + CLOSE(1) +C + ELSE IF (NR(2) .EQ. 7) THEN + NOTE = 'Ackermann 1989: track-guided bus' + IF (LSAME(DEF,'D')) THEN + DPAR(1) = .15D2 + DPAR(2) = .1D2 + END IF + IF ((DPAR(1) .LT. .995D1) .OR. (DPAR(1) .GT. .16D2)) INFO = -3 + IF ((DPAR(1) .LT. .1D1) .OR. (DPAR(1) .GT. .2D2)) INFO = -3 + N = 5 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,1) = -.668D3 / (DPAR(1)*DPAR(2)) + A(1,2) = -ONE + .1804D3 / (DPAR(1)*DPAR(2)**2) + A(2,1) = .1804D3 / (.1086D2*DPAR(1)) + A(2,2) = -.44175452D4 / (.1086D2*DPAR(1)*DPAR(2)) + A(1,5) = 198 / (DPAR(1)*DPAR(2)) + A(2,5) = .72666D3 / (.1086D2*DPAR(1)) + A(3,1) = DPAR(2) + A(3,4) = DPAR(2) + A(4,2) = ONE + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(5,1) = ONE + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,3) = ONE + C(1,4) = .612D1 + D(1,1) = 0 +C + ELSE + INFO = -2 + END IF +C + ELSE IF (NR(1) .EQ. 3) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Laub 1979, Ex.4: string of high speed vehicles' + IF (LSAME(DEF,'D')) IPAR(1) = 20 + IF (IPAR(1) .LT. 2) INFO = -4 + N = 2*IPAR(1) - 1 + M = IPAR(1) + P = IPAR(1) - 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + DO 310 I = 1, N + IF (MOD(I,2) .EQ. 1) THEN + A(I,I) = -ONE + B(I,(I+1)/2) = ONE + ELSE + A(I,I-1) = ONE + A(I,I+1) = -ONE + C(I/2,I) = ONE + END IF +310 CONTINUE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Hodel et al. 1996: heat flow in a thin rod' + IF (LSAME(DEF,'D')) IPAR(1) = 100 + IF (IPAR(1) .LT. 1) INFO = -4 + N = IPAR(1) + M = 1 + P = N + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + TEMP = DBLE(N + 1) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, -TWO * TEMP, A, LDA) + A(1,1) = -TEMP + DO 320 I = 1, N - 1 + A(I,I+1) = TEMP + A(I+1,I) = TEMP +320 CONTINUE + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(N,1) = TEMP + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'Laub 1979, Ex.6' + IF (LSAME(DEF,'D')) IPAR(1) = 21 + IF (IPAR(1) .LT. 1) INFO = -4 + N = IPAR(1) + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(N,1) = ONE + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'Lang/Penzl 1994: rotating axle' + IF (LSAME(DEF,'D')) IPAR(1) = 211 + IF ((IPAR(1) .LT. 1) .OR. (IPAR(1) .GT. 211)) INFO = -4 + N = 2*IPAR(1) - 1 + M = IPAR(1) + P = IPAR(1) + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (LDWORK .LT. M*4) INFO = -21 + IF (INFO .NE. 0) RETURN +C + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD01304.dat') + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 330 I = 1, M*4 + READ (1, FMT = *, IOSTAT = STATUS) DWORK(I) + IF (STATUS .NE. 0) INFO = 1 +330 CONTINUE + END IF + CLOSE(1) + IF (INFO .NE. 0) RETURN + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + E(1,1) = DWORK(1) + DO 340 I = 2, M + E(I,I-1) = DWORK((I-2) * 4 + 1) + E(I,I) = -DWORK((I-1) * 4 + 1) +340 CONTINUE + E(M,M) = -E(M,M) + DO 350 I = M-1, 1, -1 + DO 345 J = I, M + IF (I .EQ. 1) THEN + E(J,I) = E(J,I) - E(J,I+1) + ELSE + E(J,I) = E(J,I+1) - E(J,I) + END IF +345 CONTINUE +350 CONTINUE + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + DO 360 I = 2, M + A(I-1,I) = DWORK((I-2) * 4 + 3) + A(I,I) = -TWO * DWORK((I-2) * 4 + 3) - DWORK((I-1) * 4 + 2) + A(I,1) = DWORK((I-1) * 4 + 2) - DWORK((I-2) * 4 + 2) + A(I-1,M+I-1) = DWORK((I-1) * 4) + A(I,M+I-1) = -TWO * DWORK((I-1) * 4) + IF (I .LT. M) THEN + A(I+1,I) = DWORK((I-2) * 4 + 3) + DO 355 J = I+1, M + A(J,I) = A(J,I) + DWORK((J-2) * 4 + 2) + 1 - DWORK((J-1) * 4 + 2) +355 CONTINUE + A(I+1,M+I-1) = DWORK((I-1) * 4) + END IF +360 CONTINUE + A(1,1) = -DWORK(2) + A(1,2) = -DWORK(3) + A(1,M+1) = -A(1,M+1) + CALL DLASET('A', M-1, M-1, ZERO, ONE, A(M+1,2), LDA) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + DO 370 I = 2, M + B(I,I) = -ONE + B(I,I-1) = ONE + C(I,I) = DWORK((I-2) * 4 + 3) + C(I,M+I-1) = DWORK((I-1) * 4) +370 CONTINUE + B(1,1) = ONE + C(1,1) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE + INFO = -2 + END IF +C + ELSE IF (NR(1) .EQ. 4) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Rosen/Wang 1995: control of 1-dim. heat flow' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 100 + DPAR(1) = .1D-1 + DPAR(2) = ONE + DPAR(3) = ONE + DPAR(4) = .2D0 + DPAR(5) = .3D0 + DPAR(6) = .2D0 + DPAR(7) = .3D0 + END IF + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + VEC(4) = .TRUE. + APPIND = DBLE(N + 1) + TTEMP = -DPAR(1) * APPIND + TEMP = 1 / (.6D1 * APPIND) + CALL DLASET('A', N, N, ZERO, FOUR*TEMP, E, LDE) + CALL DLASET('A', N, N, ZERO, TWO*TTEMP, A, LDA) + DO 410 I = 1, N - 1 + A(I+1,I) = -TTEMP + A(I,I+1) = -TTEMP + E(I+1,I) = TEMP + E(I,I+1) = TEMP +410 CONTINUE + DO 420 I = 1, N + B1 = MAX(DBLE(I-1)/APPIND, DPAR(4)) + B2 = MIN(DBLE(I+1)/APPIND, DPAR(5)) + C1 = MAX(DBLE(I-1)/APPIND, DPAR(6)) + C2 = MIN(DBLE(I+1)/APPIND, DPAR(7)) + IF (B1 .GE. B2) THEN + B(I,1) = ZERO + ELSE + B(I,1) = B2 - B1 + TEMP = MIN(B2, DBLE(I)/APPIND) + IF (B1 .LT. TEMP) THEN + B(I,1) = B(I,1) + APPIND*(TEMP**2 - B1**2)/TWO + B(I,1) = B(I,1) + DBLE(I)*(B1 - TEMP) + END IF + TEMP = MAX(B1, DBLE(I)/APPIND) + IF (TEMP .LT. B2) THEN + B(I,1) = B(I,1) - APPIND*(B2**2 - TEMP**2)/TWO + B(I,1) = B(I,1) - DBLE(I)*(TEMP - B2) + END IF + END IF + IF (C1 .GE. C2) THEN + C(1,I) = ZERO + ELSE + C(1,I) = C2 - C1 + TEMP = MIN(C2, DBLE(I)/APPIND) + IF (C1 .LT. TEMP) THEN + C(1,I) = C(1,I) + APPIND*(TEMP**2 - C1**2)/TWO + C(1,I) = C(1,I) + DBLE(I)*(C1 - TEMP) + END IF + TEMP = MAX(C1, DBLE(I)/APPIND) + IF (TEMP .LT. C2) THEN + C(1,I) = C(1,I) - APPIND*(C2**2 - TEMP**2)/TWO + C(1,I) = C(1,I) - DBLE(I)*(TEMP - C2) + END IF + END IF +420 CONTINUE + CALL DSCAL(N, DPAR(2), B(1,1), 1) + CALL DSCAL(N, DPAR(3), C(1,1), LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Hench et al. 1995: coupled springs, dashpots, masses' + IF (LSAME(DEF,'D')) THEN + IPAR(1) = 30 + DPAR(1) = FOUR + DPAR(2) = FOUR + DPAR(3) = ONE + END IF + IF (IPAR(1) .LT. 2) INFO = -4 + L = IPAR(1) + N = 2*L + M = 2 + P = 2*L + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + VEC(4) = .TRUE. + CALL DLASET('A', N, N, ZERO, DPAR(1), E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + TEMP = -TWO * DPAR(3) + DO 430 I = 1, L + E(I,I) = ONE + A(I,I+L) = ONE + A(I+L,I+L) = -DPAR(2) + IF (I .LT. L) THEN + A(I+L,I+1) = DPAR(3) + A(I+L+1,I) = DPAR(3) + IF (I .GT. 1) THEN + A(I+L,I) = TEMP + END IF + END IF + 430 CONTINUE + A(L+1,1) = -DPAR(3) + A(N,L) = -DPAR(3) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(L+1,1) = ONE + B(N,2) = -ONE + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE + INFO = -2 + END IF + ELSE + INFO = -2 + END IF +C + RETURN +C *** Last Line of BD01AD *** + END diff --git a/mex/sources/libslicot/BD02AD.f b/mex/sources/libslicot/BD02AD.f new file mode 100644 index 000000000..ebe6f4a70 --- /dev/null +++ b/mex/sources/libslicot/BD02AD.f @@ -0,0 +1,601 @@ + SUBROUTINE BD02AD( DEF, NR, DPAR, IPAR, VEC, N, M, P, E, LDE, A, + 1 LDA, B, LDB, C, LDC, D, LDD, NOTE, DWORK, + 2 LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate benchmark examples for time-invariant, +C discrete-time dynamical systems +C +C E x_k+1 = A x_k + B u_k +C +C y_k = C x_k + D u_k +C +C E, A are real N-by-N matrices, B is N-by-M, C is P-by-N, and +C D is P-by-M. In many examples, E is the identity matrix and D is +C the zero matrix. +C +C This routine is an implementation of the benchmark library +C DTDSX (Version 1.0) described in [1]. +C +C ARGUMENTS +C +C Mode Parameters +C +C DEF CHARACTER*1 +C Specifies the kind of values used as parameters when +C generating parameter-dependent and scalable examples +C (i.e., examples with NR(1) = 2, 3, or 4): +C = 'D': Default values defined in [1] are used; +C = 'N': Values set in DPAR and IPAR are used. +C This parameter is not referenced if NR(1) = 1. +C Note that the scaling parameter of examples with +C NR(1) = 3 or 4 is considered as a regular parameter in +C this context. +C +C Input/Output Parameters +C +C NR (input) INTEGER array, dimension (2) +C Specifies the index of the desired example according +C to [1]. +C NR(1) defines the group: +C 1 : parameter-free problems of fixed size +C 2 : parameter-dependent problems of fixed size +C 3 : parameter-free problems of scalable size +C 4 : parameter-dependent problems of scalable size +C NR(2) defines the number of the benchmark example +C within a certain group according to [1]. +C +C DPAR (input/output) DOUBLE PRECISION array, dimension (7) +C On entry, if DEF = 'N' and the desired example depends on +C real parameters, then the array DPAR must contain the +C values for these parameters. +C For an explanation of the parameters see [1]. +C For Example 2.1, DPAR(1), ..., DPAR(3) define the +C parameters 'tau', 'delta', 'K', respectively. +C On exit, if DEF = 'D' and the desired example depends on +C real parameters, then the array DPAR is overwritten by the +C default values given in [1]. +C +C IPAR (input/output) INTEGER array, dimension (1) +C On entry, if DEF = 'N' and the desired example depends on +C integer parameters, then the array IPAR must contain the +C values for these parameters. +C For an explanation of the parameters see [1]. +C For Example 3.1, IPAR(1) defines the parameter 'n'. +C On exit, if DEF = 'D' and the desired example depends on +C integer parameters, then the array IPAR is overwritten by +C the default values given in [1]. +C +C VEC (output) LOGICAL array, dimension (8) +C Flag vector which displays the availabilty of the output +C data: +C VEC(1), ..., VEC(3) refer to N, M, and P, respectively, +C and are always .TRUE.. +C VEC(4) is .TRUE. iff E is NOT the identity matrix. +C VEC(5), ..., VEC(7) refer to A, B, and C, respectively, +C and are always .TRUE.. +C VEC(8) is .TRUE. iff D is NOT the zero matrix. +C +C N (output) INTEGER +C The actual state dimension, i.e., the order of the +C matrices E and A. +C +C M (output) INTEGER +C The number of columns in the matrices B and D. +C +C P (output) INTEGER +C The number of rows in the matrices C and D. +C +C E (output) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array contains the +C matrix E. +C NOTE that this array is overwritten (by the identity +C matrix), if VEC(4) = .FALSE.. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= N. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array contains the +C matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array contains the +C matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= P. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array contains the +C matrix D. +C NOTE that this array is overwritten (by the zero +C matrix), if VEC(8) = .FALSE.. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= P. +C +C NOTE (output) CHARACTER*70 +C String containing short information about the chosen +C example. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C NOTE that DWORK is not used in the current version +C of BD02AD. +C +C LDWORK INTEGER +C LDWORK >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; in particular, INFO = -3 or -4 indicates +C that at least one of the parameters in DPAR or +C IPAR, respectively, has an illegal value; +C = 1: data file can not be opened or has wrong format. +C +C REFERENCES +C +C [1] Kressner, D., Mehrmann, V. and Penzl, T. +C DTDSX - a Collection of Benchmark Examples for State-Space +C Realizations of Discrete-Time Dynamical Systems. +C SLICOT Working Note 1998-10. 1998. +C +C NUMERICAL ASPECTS +C +C None +C +C CONTRIBUTOR +C +C D. Kressner, V. Mehrmann, and T. Penzl (TU Chemnitz) +C +C For questions concerning the collection or for the submission of +C test examples, please contact Volker Mehrmann +C (Email: volker.mehrmann@mathematik.tu-chemnitz.de). +C +C REVISIONS +C +C June 1999, V. Sima. +C +C KEYWORDS +C +C discrete-time dynamical systems +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, PI + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + 1 THREE = 3.0D0, FOUR = 4.0D0, + 2 PI = .3141592653589793D1 ) +C .. Scalar Arguments .. + CHARACTER DEF + CHARACTER*70 NOTE + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, P +C .. Array Arguments .. + LOGICAL VEC(8) + INTEGER IPAR(*), NR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DPAR(*), + 1 DWORK(*), E(LDE,*) +C .. Local Scalars .. + CHARACTER*12 DATAF + INTEGER I, J, STATUS + DOUBLE PRECISION TEMP +C .. Local Arrays .. + LOGICAL VECDEF(8) +C .. External Functions .. +C . LAPACK . + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. +C . LAPACK . + EXTERNAL DLASET +C .. Data Statements .. +C . default values for availabities . + DATA VECDEF /.TRUE., .TRUE., .TRUE., .FALSE., + 1 .TRUE., .TRUE., .TRUE., .FALSE./ +C +C .. Executable Statements .. +C + INFO = 0 + DO 10 I = 1, 8 + VEC(I) = VECDEF(I) +10 CONTINUE +C + IF (NR(1) .EQ. 1) THEN +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Laub 1979, Ex. 2: uncontrollable-unobservable data' + N = 2 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + A(1,1) = FOUR + A(2,1) = -.45D1 + A(1,2) = THREE + A(2,2) = -.35D1 + CALL DLASET('A', N, M, -ONE, ONE, B, LDB) + C(1,1) = 3.0D0 + C(1,2) = 2.0D0 + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 2) THEN + NOTE = 'Laub 1979, Ex. 3' + N = 2 + M = 2 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,1) = .9512D0 + A(2,2) = .9048D0 + B(1,1) = .4877D1 + B(1,2) = .4877D1 + B(2,1) = -.11895D1 + B(2,2) = .3569D1 + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 3) THEN + NOTE = 'Van Dooren 1981, Ex. II' + N = 2 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + A(1,1) = TWO + A(2,1) = ONE + A(1,2) = -ONE + A(2,2) = ZERO + CALL DLASET('A', N, M, ZERO, ONE, B, LDB) + CALL DLASET('A', P, N, ONE, ZERO, C, LDC) + D(1,1) = ZERO +C + ELSE IF (NR(2) .EQ. 4) THEN + NOTE = 'Ionescu/Weiss 1992' + N = 2 + M = 2 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + A(2,2) = -ONE + CALL DLASET('A', N, M, ZERO, ONE, B, LDB) + B(2,1) = TWO + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 5) THEN + NOTE = 'Jonckheere 1981' + N = 2 + M = 1 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + CALL DLASET('A', N, M, ONE, ZERO, B, LDB) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 6) THEN + NOTE = 'Ackerson/Fu 1970: satellite control problem' + N = 4 + M = 2 + P = 4 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 7) THEN + NOTE = 'Litkouhi 1983: system with slow and fast modes' + N = 4 + M = 2 + P = 4 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 8) THEN + NOTE = 'Lu/Lin 1993, Ex. 4.3' + N = 4 + M = 4 + P = 4 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('U', P, N, ONE, ONE, C, LDC) + C(1,3) = TWO + C(1,4) = FOUR + C(2,4) = TWO + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 9) THEN + NOTE = 'Gajic/Shen 1993, Section 2.7.4: chemical plant' + N = 5 + M = 2 + P = 5 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 10) THEN + NOTE = 'Davison/Wang 1974' + N = 6 + M = 2 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN + VEC(8) = .TRUE. +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + A(1,2) = ONE + A(2,3) = ONE + A(4,5) = ONE + A(5,6) = ONE + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(3,1) = ONE + B(6,2) = ONE + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + C(1,2) = ONE + C(2,4) = ONE + C(2,5) = -ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) + D(1,1) = ONE + D(2,1) = ONE +C + ELSE IF (NR(2) .EQ. 11) THEN + NOTE = 'Patnaik et al. 1980: tubular ammonia reactor' + N = 9 + M = 3 + P = 2 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + C(2,5) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE IF (NR(2) .EQ. 12) THEN + NOTE = 'Smith 1969: two-stand cold rolling mill' + N = 10 + M = 3 + P = 5 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN + VEC(8) = .TRUE. +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N, N, ZERO, ONE, A(2,1), LDA) + A(1,10) = .112D0 + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(1,1) = .276D1 + B(1,2) = -.135D1 + B(1,3) = -.46D0 + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,1) = ONE + C(2,10) = .894D0 + C(3,10) = -.1693D2 + C(4,10) = .7D-1 + C(5,10) = .398D0 + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = 'BD02112.dat') + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 110 I = 1, P + READ (1, FMT = *, IOSTAT = STATUS) (D(I,J), J = 1, M) + IF (STATUS .NE. 0) INFO = 1 +110 CONTINUE + END IF + CLOSE(1) +C + ELSE + INFO = -2 + END IF +C + IF (((NR(2) .GE. 6) .AND. (NR(2) .LE. 9)) .OR. + 1 (NR(2) .EQ. 11)) THEN +C .. loading data files + WRITE (DATAF(1:11), '(A,I2.2,A)') 'BD021', NR(2), '.dat' + OPEN(1, IOSTAT = STATUS, STATUS = 'OLD', FILE = DATAF(1:11)) + IF (STATUS .NE. 0) THEN + INFO = 1 + ELSE + DO 120 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (A(I,J), J = 1, N) + IF (STATUS .NE. 0) INFO = 1 +120 CONTINUE + DO 130 I = 1, N + READ (1, FMT = *, IOSTAT = STATUS) (B(I,J), J = 1, M) + IF (STATUS .NE. 0) INFO = 1 +130 CONTINUE + END IF + CLOSE(1) + END IF +C + ELSE IF (NR(1) .EQ. 2) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Pappas et al. 1980: process control of paper machine' + IF (LSAME(DEF,'D')) THEN + DPAR(1) = .1D9 + DPAR(2) = ONE + DPAR(3) = ONE + END IF + IF (DPAR(1) .EQ. ZERO) INFO = -3 + N = 4 + M = 1 + P = 1 + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + TEMP = DPAR(2) / DPAR(1) + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N-1, N-1, ZERO, ONE, A(2,1), LDA) + A(1,1) = ONE - TEMP + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(1,1) = DPAR(3) * TEMP + CALL DLASET('A', P, N, ZERO, ZERO, C, LDC) + C(1,4) = ONE + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE + INFO = -2 + END IF +C + ELSE IF (NR(1) .EQ. 3) THEN + IF (.NOT. (LSAME(DEF,'D') .OR. LSAME(DEF,'N'))) THEN + INFO = -1 + RETURN + END IF +C + IF (NR(2) .EQ. 1) THEN + NOTE = 'Pappas et al. 1980, Ex. 3' + IF (LSAME(DEF,'D')) IPAR(1) = 100 + IF (IPAR(1) .LT. 2) INFO = -4 + N = IPAR(1) + M = 1 + P = N + IF (LDE .LT. N) INFO = -10 + IF (LDA .LT. N) INFO = -12 + IF (LDB .LT. N) INFO = -14 + IF (LDC .LT. P) INFO = -16 + IF (LDD .LT. P) INFO = -18 + IF (INFO .NE. 0) RETURN +C + CALL DLASET('A', N, N, ZERO, ONE, E, LDE) + CALL DLASET('A', N, N, ZERO, ZERO, A, LDA) + CALL DLASET('A', N-1, N-1, ZERO, ONE, A(1,2), LDA) + CALL DLASET('A', N, M, ZERO, ZERO, B, LDB) + B(N,1) = ONE + CALL DLASET('A', P, N, ZERO, ONE, C, LDC) + CALL DLASET('A', P, M, ZERO, ZERO, D, LDD) +C + ELSE + INFO = -2 + END IF +C + ELSE + INFO = -2 + END IF +C + RETURN +C *** Last Line of BD02AD *** + END diff --git a/mex/sources/libslicot/DE01OD.f b/mex/sources/libslicot/DE01OD.f new file mode 100644 index 000000000..b2b0a608a --- /dev/null +++ b/mex/sources/libslicot/DE01OD.f @@ -0,0 +1,203 @@ + SUBROUTINE DE01OD( CONV, N, A, B, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the convolution or deconvolution of two real signals +C A and B. +C +C ARGUMENTS +C +C Mode Parameters +C +C CONV CHARACTER*1 +C Indicates whether convolution or deconvolution is to be +C performed as follows: +C = 'C': Convolution; +C = 'D': Deconvolution. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of samples. N must be a power of 2. N >= 2. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the first signal. +C On exit, this array contains the convolution (if +C CONV = 'C') or deconvolution (if CONV = 'D') of the two +C signals. +C +C B (input) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the second signal. +C NOTE that this array is overwritten. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine computes the convolution or deconvolution of two real +C signals A and B using an FFT algorithm (SLICOT Library routine +C DG01MD). +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N*log(N) ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DE01CD by R. Dekeyser, State +C University of Gent, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Convolution, deconvolution, digital signal processing, fast +C Fourier transform, real signals. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF=0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER CONV + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*) +C .. Local Scalars .. + LOGICAL LCONV + INTEGER J, KJ, ND2P1 + DOUBLE PRECISION AC, AS, AST, BC, BS, CI, CR +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DG01MD, DLADIV, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MOD +C .. Executable Statements .. +C + INFO = 0 + LCONV = LSAME( CONV, 'C' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN + INFO = -1 + ELSE + J = 0 + IF( N.GE.2 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + GO TO 10 + END IF +C END WHILE 10 + END IF + IF ( J.NE.1 ) INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DE01OD', -INFO ) + RETURN + END IF +C +C Fourier transform. +C + CALL DG01MD( 'Direct', N, A, B, INFO ) +C + IF ( LCONV ) THEN + AST = A(1)*B(1) + ELSE + IF ( B(1).EQ.ZERO ) THEN + AST = ZERO + ELSE + AST = A(1)/B(1) + END IF + END IF +C + ND2P1 = N/2 + 1 + J = ND2P1 +C + DO 20 KJ = ND2P1, N +C +C Components of the transform of function A. +C + AC = HALF*( A(J) + A(KJ) ) + AS = HALF*( B(J) - B(KJ) ) +C +C Components of the transform of function B. +C + BC = HALF*( B(KJ) + B(J) ) + BS = HALF*( A(KJ) - A(J) ) +C +C Deconvolution by complex division if CONV = 'D'; +C Convolution by complex multiplication if CONV = 'C'. +C + IF ( LCONV ) THEN + CR = AC*BC - AS*BS + CI = AS*BC + AC*BS + ELSE + IF ( MAX( ABS( BC ), ABS( BS ) ).EQ.ZERO ) THEN + CR = ZERO + CI = ZERO + ELSE + CALL DLADIV( AC, AS, BC, BS, CR, CI ) + END IF + END IF +C + A(J) = CR + B(J) = CI + A(KJ) = CR + B(KJ) = -CI + J = J - 1 + 20 CONTINUE + A(1) = AST + B(1) = ZERO +C +C Inverse Fourier transform. +C + CALL DG01MD( 'Inverse', N, A, B, INFO ) +C + CALL DSCAL( N, ONE/DBLE( N ), A, 1 ) +C + RETURN +C *** Last line of DE01OD *** + END diff --git a/mex/sources/libslicot/DE01PD.f b/mex/sources/libslicot/DE01PD.f new file mode 100644 index 000000000..0358e8036 --- /dev/null +++ b/mex/sources/libslicot/DE01PD.f @@ -0,0 +1,236 @@ + SUBROUTINE DE01PD( CONV, WGHT, N, A, B, W, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the convolution or deconvolution of two real signals +C A and B using the Hartley transform. +C +C ARGUMENTS +C +C Mode Parameters +C +C CONV CHARACTER*1 +C Indicates whether convolution or deconvolution is to be +C performed as follows: +C = 'C': Convolution; +C = 'D': Deconvolution. +C +C WGHT CHARACTER*1 +C Indicates whether the precomputed weights are available +C or not, as follows: +C = 'A': available; +C = 'N': not available. +C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is +C set to 'A' on exit. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of samples. N must be a power of 2. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the first signal. +C On exit, this array contains the convolution (if +C CONV = 'C') or deconvolution (if CONV = 'D') of the two +C signals. +C +C B (input) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the second signal. +C NOTE that this array is overwritten. +C +C W (input/output) DOUBLE PRECISION array, +C dimension (N - LOG2(N)) +C On entry with WGHT = 'A', this array must contain the long +C weight vector computed by a previous call of this routine +C or of the SLICOT Library routine DG01OD.f, with the same +C value of N. If WGHT = 'N', the contents of this array on +C entry is ignored. +C On exit, this array contains the long weight vector. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine computes the convolution or deconvolution of two +C real signals A and B using three scrambled Hartley transforms +C (SLICOT Library routine DG01OD). +C +C REFERENCES +C +C [1] Van Loan, Charles. +C Computational frameworks for the fast Fourier transform. +C SIAM, 1992. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N log(N)) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, April 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C KEYWORDS +C +C Convolution, deconvolution, digital signal processing, +C fast Hartley transform, real signals. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HALF, ONE, TWO + PARAMETER ( HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER CONV, WGHT + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*), W(*) +C .. Local Scalars .. + LOGICAL LCONV, LWGHT + INTEGER J, L, LEN, M, P1, R1 + DOUBLE PRECISION T1, T2, T3 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DG01OD, DLADIV, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MOD +C .. Executable Statements .. +C + INFO = 0 + LCONV = LSAME( CONV, 'C' ) + LWGHT = LSAME( WGHT, 'A' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LCONV .AND. .NOT.LSAME( CONV, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN + INFO = -2 + ELSE + M = 0 + J = 0 + IF( N.GE.1 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + M = M + 1 + GO TO 10 + END IF +C END WHILE 10 + IF ( J.NE.1 ) INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DE01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.LE.0 ) THEN + RETURN + ELSE IF ( N.EQ.1 ) THEN + IF ( LCONV ) THEN + A(1) = A(1)*B(1) + ELSE + A(1) = A(1)/B(1) + END IF + RETURN + END IF +C +C Scrambled Hartley transforms of A and B. +C + CALL DG01OD( 'OutputScrambled', WGHT, N, A, W, INFO ) + CALL DG01OD( 'OutputScrambled', WGHT, N, B, W, INFO ) +C +C Something similar to a Hadamard product/quotient. +C + LEN = 1 + IF( LCONV ) THEN + A(1) = TWO*A(1)*B(1) + A(2) = TWO*A(2)*B(2) +C + DO 30 L = 1, M - 1 + LEN = 2*LEN + R1 = 2*LEN +C + DO 20 P1 = LEN + 1, LEN + LEN/2 + T1 = B(P1) + B(R1) + T2 = B(P1) - B(R1) + T3 = T2*A(P1) + A(P1) = T1*A(P1) + T2*A(R1) + A(R1) = T1*A(R1) - T3 + R1 = R1 - 1 + 20 CONTINUE +C + 30 CONTINUE +C + ELSE +C + A(1) = HALF*A(1)/B(1) + A(2) = HALF*A(2)/B(2) +C + DO 50 L = 1, M - 1 + LEN = 2*LEN + R1 = 2*LEN +C + DO 40 P1 = LEN + 1, LEN + LEN/2 + CALL DLADIV( A(P1), A(R1), B(P1)+B(R1), B(R1)-B(P1), T1, + $ T2 ) + A(P1) = T1 + A(R1) = T2 + R1 = R1 - 1 + 40 CONTINUE +C + 50 CONTINUE +C + END IF +C +C Transposed Hartley transform of A. +C + CALL DG01OD( 'InputScrambled', WGHT, N, A, W, INFO ) + IF ( LCONV ) THEN + CALL DSCAL( N, HALF/DBLE( N ), A, 1 ) + ELSE + CALL DSCAL( N, TWO/DBLE( N ), A, 1 ) + END IF +C + RETURN +C *** Last line of DE01PD *** + END diff --git a/mex/sources/libslicot/DF01MD.f b/mex/sources/libslicot/DF01MD.f new file mode 100644 index 000000000..1dafa4b97 --- /dev/null +++ b/mex/sources/libslicot/DF01MD.f @@ -0,0 +1,299 @@ + SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the sine transform or cosine transform of a real +C signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C SICO CHARACTER*1 +C Indicates whether the sine transform or cosine transform +C is to be computed as follows: +C = 'S': The sine transform is computed; +C = 'C': The cosine transform is computed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of samples. N must be a power of 2 plus 1. +C N >= 5. +C +C DT (input) DOUBLE PRECISION +C The sampling time of the signal. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the signal to be +C processed. +C On exit, this array contains either the sine transform, if +C SICO = 'S', or the cosine transform, if SICO = 'C', of the +C given signal. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N+1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let A(1), A(2),..., A(N) be a real signal of N samples. +C +C If SICO = 'S', the routine computes the sine transform of A as +C follows. First, transform A(i), i = 1,2,...,N, into the complex +C signal B(i), i = 1,2,...,(N+1)/2, where +C +C B(1) = -2*A(2), +C B(i) = {A(2i-2) - A(2i)} - j*A(2i-1) for i = 2,3,...,(N-1)/2, +C B((N+1)/2) = 2*A(N-1) and j**2 = -1. +C +C Next, perform a discrete inverse Fourier transform on B(i) by +C calling SLICOT Library Routine DG01ND, to give the complex signal +C Z(i), i = 1,2,...,(N-1)/2, from which the real signal C(i) may be +C obtained as follows: +C +C C(2i-1) = Re(Z(i)), C(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. +C +C Finally, compute the sine transform coefficients S ,S ,...,S +C 1 2 N +C given by +C +C S = 0, +C 1 +C { [C(k) + C(N+1-k)] } +C S = DT*{[C(k) - C(N+1-k)] - -----------------------}, +C k { [2*sin(pi*(k-1)/(N-1))]} +C +C for k = 2,3,...,N-1, and +C +C S = 0. +C N +C +C If SICO = 'C', the routine computes the cosine transform of A as +C follows. First, transform A(i), i = 1,2,...,N, into the complex +C signal B(i), i = 1,2,...,(N+1)/2, where +C +C B(1) = 2*A(1), +C B(i) = 2*A(2i-1) + 2*j*{[A(2i-2) - A(2i)]} +C for i = 2,3,...,(N-1)/2 and B((N+1)/2) = 2*A(N). +C +C Next, perform a discrete inverse Fourier transform on B(i) by +C calling SLICOT Library Routine DG01ND, to give the complex signal +C Z(i), i = 1,2,...,(N-1)/2, from which the real signal D(i) may be +C obtained as follows: +C +C D(2i-1) = Re(Z(i)), D(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2. +C +C Finally, compute the cosine transform coefficients S ,S ,...,S +C 1 2 N +C given by +C +C S = 2*DT*[D(1) + A0], +C 1 +C { [D(k) - D(N+1-k)] } +C S = DT*{[D(k) + D(N+1-k)] - -----------------------}, +C k { [2*sin(pi*(k-1)/(N-1))]} +C +C +C for k = 2,3,...,N-1, and +C +C S = 2*DT*[D(1) - A0], +C N +C (N-1)/2 +C where A0 = 2*SUM A(2i). +C i=1 +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C [2] Oppenheim, A.V. and Schafer, R.W. +C Discrete-Time Signal Processing. +C Prentice-Hall Signal Processing Series, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N*log(N) ) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DF01AD by F. Dumortier, and +C R.M.C. Dekeyser, State University of Gent, Belgium. +C +C REVISIONS +C +C V. Sima, Jan. 2003. +C +C KEYWORDS +C +C Digital signal processing, fast Fourier transform, complex +C signals. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ FOUR = 4.0D0 ) +C .. Scalar Arguments .. + CHARACTER SICO + INTEGER INFO, N + DOUBLE PRECISION DT +C .. Array Arguments .. + DOUBLE PRECISION A(*), DWORK(*) +C .. Local Scalars .. + LOGICAL LSICO, LSIG + INTEGER I, I2, IND1, IND2, M, MD2 + DOUBLE PRECISION A0, PIBYM, W1, W2, W3 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DG01ND, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, DBLE, MOD, SIN +C .. Executable Statements .. +C + INFO = 0 + LSICO = LSAME( SICO, 'S' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LSICO .AND. .NOT.LSAME( SICO, 'C' ) ) THEN + INFO = -1 + ELSE + M = 0 + IF( N.GT.4 ) THEN + M = N - 1 +C WHILE ( MOD( M, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( M, 2 ).EQ.0 ) THEN + M = M/2 + GO TO 10 + END IF +C END WHILE 10 + END IF + IF ( M.NE.1 ) INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DF01MD', -INFO ) + RETURN + END IF +C +C Initialisation. +C + M = N - 1 + MD2 = ( N + 1 )/2 + PIBYM = FOUR*ATAN( ONE )/DBLE( M ) + I2 = 1 + DWORK(MD2+1) = ZERO + DWORK(2*MD2) = ZERO +C + IF ( LSICO ) THEN +C +C Sine transform. +C + LSIG = .TRUE. + DWORK(1) = -TWO*A(2) + DWORK(MD2) = TWO*A(M) +C + DO 20 I = 4, M, 2 + I2 = I2 + 1 + DWORK(I2) = A(I-2) - A(I) + DWORK(MD2+I2) = -A(I-1) + 20 CONTINUE +C + ELSE +C +C Cosine transform. +C + LSIG = .FALSE. + DWORK(1) = TWO*A(1) + DWORK(MD2) = TWO*A(N) + A0 = A(2) +C + DO 30 I = 4, M, 2 + I2 = I2 + 1 + DWORK(I2) = TWO*A(I-1) + DWORK(MD2+I2) = TWO*( A(I-2) - A(I) ) + A0 = A0 + A(I) + 30 CONTINUE +C + A0 = TWO*A0 + END IF +C +C Inverse Fourier transform. +C + CALL DG01ND( 'Inverse', MD2-1, DWORK(1), DWORK(MD2+1), INFO ) +C +C Sine or cosine coefficients. +C + IF ( LSICO ) THEN + A(1) = ZERO + A(N) = ZERO + ELSE + A(1) = TWO*DT*( DWORK(1) + A0 ) + A(N) = TWO*DT*( DWORK(1) - A0 ) + END IF +C + IND1 = MD2 + 1 + IND2 = N +C + DO 40 I = 1, M - 1, 2 + W1 = DWORK(IND1) + W2 = DWORK(IND2) + IF ( LSIG ) W2 = -W2 + W3 = TWO*SIN( PIBYM*DBLE( I ) ) + A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) + IND1 = IND1 + 1 + IND2 = IND2 - 1 + 40 CONTINUE +C + IND1 = 2 + IND2 = MD2 - 1 +C + DO 50 I = 2, M - 2, 2 + W1 = DWORK(IND1) + W2 = DWORK(IND2) + IF ( LSIG ) W2 = -W2 + W3 = TWO*SIN( PIBYM*DBLE( I ) ) + A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 ) + IND1 = IND1 + 1 + IND2 = IND2 - 1 + 50 CONTINUE +C + RETURN +C *** Last line of DF01MD *** + END diff --git a/mex/sources/libslicot/DG01MD.f b/mex/sources/libslicot/DG01MD.f new file mode 100644 index 000000000..ac91ab314 --- /dev/null +++ b/mex/sources/libslicot/DG01MD.f @@ -0,0 +1,235 @@ + SUBROUTINE DG01MD( INDI, N, XR, XI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the discrete Fourier transform, or inverse transform, +C of a complex signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C INDI CHARACTER*1 +C Indicates whether a Fourier transform or inverse Fourier +C transform is to be performed as follows: +C = 'D': (Direct) Fourier transform; +C = 'I': Inverse Fourier transform. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of complex samples. N must be a power of 2. +C N >= 2. +C +C XR (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the real part of either +C the complex signal z if INDI = 'D', or f(z) if INDI = 'I'. +C On exit, this array contains either the real part of the +C computed Fourier transform f(z) if INDI = 'D', or the +C inverse Fourier transform z of f(z) if INDI = 'I'. +C +C XI (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the imaginary part of +C either z if INDI = 'D', or f(z) if INDI = 'I'. +C On exit, this array contains either the imaginary part of +C f(z) if INDI = 'D', or z if INDI = 'I'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If INDI = 'D', then the routine performs a discrete Fourier +C transform on the complex signal Z(i), i = 1,2,...,N. If the result +C is denoted by FZ(k), k = 1,2,...,N, then the relationship between +C Z and FZ is given by the formula: +C +C N ((k-1)*(i-1)) +C FZ(k) = SUM ( Z(i) * V ), +C i=1 +C 2 +C where V = exp( -2*pi*j/N ) and j = -1. +C +C If INDI = 'I', then the routine performs an inverse discrete +C Fourier transform on the complex signal FZ(k), k = 1,2,...,N. If +C the result is denoted by Z(i), i = 1,2,...,N, then the +C relationship between Z and FZ is given by the formula: +C +C N ((k-1)*(i-1)) +C Z(i) = SUM ( FZ(k) * W ), +C k=1 +C +C where W = exp( 2*pi*j/N ). +C +C Note that a discrete Fourier transform, followed by an inverse +C discrete Fourier transform, will result in a signal which is a +C factor N larger than the original input signal. +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N*log(N) ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DG01AD by R. Dekeyser, State +C University of Gent, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Complex signals, digital signal processing, fast Fourier +C transform. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ TWO = 2.0D0, EIGHT = 8.0D0 ) +C .. Scalar Arguments .. + CHARACTER INDI + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION XI(*), XR(*) +C .. Local Scalars .. + LOGICAL LINDI + INTEGER I, J, K, L, M + DOUBLE PRECISION PI2, TI, TR, WHELP, WI, WR, WSTPI, WSTPR +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, DBLE, MOD, SIN +C .. Executable Statements .. +C + INFO = 0 + LINDI = LSAME( INDI, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN + INFO = -1 + ELSE + J = 0 + IF( N.GE.2 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + GO TO 10 + END IF +C END WHILE 10 + END IF + IF ( J.NE.1 ) INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DG01MD', -INFO ) + RETURN + END IF +C +C Inplace shuffling of data. +C + J = 1 +C + DO 30 I = 1, N + IF ( J.GT.I ) THEN + TR = XR(I) + TI = XI(I) + XR(I) = XR(J) + XI(I) = XI(J) + XR(J) = TR + XI(J) = TI + END IF + K = N/2 +C REPEAT + 20 IF ( J.GT.K ) THEN + J = J - K + K = K/2 + IF ( K.GE.2 ) GO TO 20 + END IF +C UNTIL ( K.LT.2 ) + J = J + K + 30 CONTINUE +C +C Transform by decimation in time. +C + PI2 = EIGHT*ATAN( ONE ) + IF ( LINDI ) PI2 = -PI2 +C + I = 1 +C +C WHILE ( I.LT.N ) DO +C + 40 IF ( I.LT.N ) THEN + L = 2*I + WHELP = PI2/DBLE( L ) + WSTPI = SIN( WHELP ) + WHELP = SIN( HALF*WHELP ) + WSTPR = -TWO*WHELP*WHELP + WR = ONE + WI = ZERO +C + DO 60 J = 1, I +C + DO 50 K = J, N, L + M = K + I + TR = WR*XR(M) - WI*XI(M) + TI = WR*XI(M) + WI*XR(M) + XR(M) = XR(K) - TR + XI(M) = XI(K) - TI + XR(K) = XR(K) + TR + XI(K) = XI(K) + TI + 50 CONTINUE +C + WHELP = WR + WR = WR + WR*WSTPR - WI*WSTPI + WI = WI + WHELP*WSTPI + WI*WSTPR + 60 CONTINUE +C + I = L + GO TO 40 +C END WHILE 40 + END IF +C + RETURN +C *** Last line of DG01MD *** + END diff --git a/mex/sources/libslicot/DG01ND.f b/mex/sources/libslicot/DG01ND.f new file mode 100644 index 000000000..0a97d0ea5 --- /dev/null +++ b/mex/sources/libslicot/DG01ND.f @@ -0,0 +1,247 @@ + SUBROUTINE DG01ND( INDI, N, XR, XI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the discrete Fourier transform, or inverse Fourier +C transform, of a real signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C INDI CHARACTER*1 +C Indicates whether a Fourier transform or inverse Fourier +C transform is to be performed as follows: +C = 'D': (Direct) Fourier transform; +C = 'I': Inverse Fourier transform. +C +C Input/Output Parameters +C +C N (input) INTEGER +C Half the number of real samples. N must be a power of 2. +C N >= 2. +C +C XR (input/output) DOUBLE PRECISION array, dimension (N+1) +C On entry with INDI = 'D', the first N elements of this +C array must contain the odd part of the input signal; for +C example, XR(I) = A(2*I-1) for I = 1,2,...,N. +C On entry with INDI = 'I', the first N+1 elements of this +C array must contain the the real part of the input discrete +C Fourier transform (computed, for instance, by a previous +C call of the routine). +C On exit with INDI = 'D', the first N+1 elements of this +C array contain the real part of the output signal, that is +C of the computed discrete Fourier transform. +C On exit with INDI = 'I', the first N elements of this +C array contain the odd part of the output signal, that is +C of the computed inverse discrete Fourier transform. +C +C XI (input/output) DOUBLE PRECISION array, dimension (N+1) +C On entry with INDI = 'D', the first N elements of this +C array must contain the even part of the input signal; for +C example, XI(I) = A(2*I) for I = 1,2,...,N. +C On entry with INDI = 'I', the first N+1 elements of this +C array must contain the the imaginary part of the input +C discrete Fourier transform (computed, for instance, by a +C previous call of the routine). +C On exit with INDI = 'D', the first N+1 elements of this +C array contain the imaginary part of the output signal, +C that is of the computed discrete Fourier transform. +C On exit with INDI = 'I', the first N elements of this +C array contain the even part of the output signal, that is +C of the computed inverse discrete Fourier transform. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let A(1),....,A(2*N) be a real signal of 2*N samples. Then the +C first N+1 samples of the discrete Fourier transform of this signal +C are given by the formula: +C +C 2*N ((m-1)*(i-1)) +C FA(m) = SUM ( A(i) * W ), +C i=1 +C 2 +C where m = 1,2,...,N+1, W = exp(-pi*j/N) and j = -1. +C +C This transform can be computed as follows. First, transform A(i), +C i = 1,2,...,2*N, into the complex signal Z(i) = (X(i),Y(i)), +C i = 1,2,...,N. That is, X(i) = A(2*i-1) and Y(i) = A(2*i). Next, +C perform a discrete Fourier transform on Z(i) by calling SLICOT +C Library routine DG01MD. This gives a new complex signal FZ(k), +C such that +C +C N ((k-1)*(i-1)) +C FZ(k) = SUM ( Z(i) * V ), +C i=1 +C +C where k = 1,2,...,N, V = exp(-2*pi*j/N). Using the values of +C FZ(k), the components of the discrete Fourier transform FA can be +C computed by simple linear relations, implemented in the DG01NY +C subroutine. +C +C Finally, let +C +C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)), k = 1,2,...,N, +C +C be the contents of the arrays XR and XI on entry to DG01NY with +C INDI = 'D', then on exit XR and XI contain the real and imaginary +C parts of the Fourier transform of the original real signal A. +C That is, +C +C XR(m) = Re(FA(m)), XI(m) = Im(FA(m)), +C +C where m = 1,2,...,N+1. +C +C If INDI = 'I', then the routine evaluates the inverse Fourier +C transform of a complex signal which may itself be the discrete +C Fourier transform of a real signal. +C +C Let FA(m), m = 1,2,...,2*N, denote the full discrete Fourier +C transform of a real signal A(i), i=1,2,...,2*N. The relationship +C between FA and A is given by the formula: +C +C 2*N ((m-1)*(i-1)) +C A(i) = SUM ( FA(m) * W ), +C m=1 +C +C where W = exp(pi*j/N). +C +C Let +C +C XR(m) = Re(FA(m)) and XI(m) = Im(FA(m)) for m = 1,2,...,N+1, +C +C be the contents of the arrays XR and XI on entry to the routine +C DG01NY with INDI = 'I', then on exit the first N samples of the +C complex signal FZ are returned in XR and XI such that +C +C XR(k) = Re(FZ(k)), XI(k) = Im(FZ(k)) and k = 1,2,...,N. +C +C Next, an inverse Fourier transform is performed on FZ (e.g. by +C calling SLICOT Library routine DG01MD), to give the complex signal +C Z, whose i-th component is given by the formula: +C +C N ((k-1)*(i-1)) +C Z(i) = SUM ( FZ(k) * V ), +C k=1 +C +C where i = 1,2,...,N and V = exp(2*pi*j/N). +C +C Finally, the 2*N samples of the real signal A can then be obtained +C directly from Z. That is, +C +C A(2*i-1) = Re(Z(i)) and A(2*i) = Im(Z(i)), for i = 1,2,...N. +C +C Note that a discrete Fourier transform, followed by an inverse +C transform will result in a signal which is a factor 2*N larger +C than the original input signal. +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N*log(N) ) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DG01BD by R. Dekeyser, and +C F. Dumortier, State University of Gent, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Complex signals, digital signal processing, fast Fourier +C transform, real signals. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER INDI + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION XI(*), XR(*) +C .. Local Scalars .. + INTEGER J + LOGICAL LINDI +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DG01MD, DG01NY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MOD +C .. Executable Statements .. +C + INFO = 0 + LINDI = LSAME( INDI, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LINDI .AND. .NOT.LSAME( INDI, 'I' ) ) THEN + INFO = -1 + ELSE + J = 0 + IF( N.GE.2 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + GO TO 10 + END IF +C END WHILE 10 + END IF + IF ( J.NE.1 ) INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DG01ND', -INFO ) + RETURN + END IF +C +C Compute the Fourier transform of Z = (XR,XI). +C + IF ( .NOT.LINDI ) CALL DG01NY( INDI, N, XR, XI ) +C + CALL DG01MD( INDI, N, XR, XI, INFO ) +C + IF ( LINDI ) CALL DG01NY( INDI, N, XR, XI ) +C + RETURN +C *** Last line of DG01ND *** + END diff --git a/mex/sources/libslicot/DG01NY.f b/mex/sources/libslicot/DG01NY.f new file mode 100644 index 000000000..9b7929dee --- /dev/null +++ b/mex/sources/libslicot/DG01NY.f @@ -0,0 +1,94 @@ + SUBROUTINE DG01NY( INDI, N, XR, XI ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C For efficiency, no tests of the input scalar parameters are +C performed. +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO, EIGHT + PARAMETER ( ZERO=0.0D0, HALF=0.5D0, ONE = 1.0D0, + $ TWO=2.0D0, EIGHT=8.0D0 ) +C .. Scalar Arguments .. + CHARACTER INDI + INTEGER N +C .. Array Arguments .. + DOUBLE PRECISION XI(*), XR(*) +C .. Local Scalars .. + LOGICAL LINDI + INTEGER I, J, N2 + DOUBLE PRECISION AI, AR, BI, BR, HELPI, HELPR, PI2, WHELP, WI, + $ WR, WSTPI, WSTPR +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. Intrinsic Functions .. + INTRINSIC ATAN, DBLE, SIN +C .. Executable Statements .. +C + LINDI = LSAME( INDI, 'D' ) +C +C Initialisation. +C + PI2 = EIGHT*ATAN( ONE ) + IF ( LINDI ) PI2 = -PI2 +C + WHELP = PI2/DBLE( 2*N ) + WSTPI = SIN( WHELP ) + WHELP = SIN( HALF*WHELP ) + WSTPR = -TWO*WHELP*WHELP + WI = ZERO +C + IF ( LINDI ) THEN + WR = ONE + XR(N+1) = XR(1) + XI(N+1) = XI(1) + ELSE + WR = -ONE + END IF +C +C Recursion. +C + N2 = N/2 + 1 + DO 10 I = 1, N2 + J = N + 2 - I + AR = XR(I) + XR(J) + AI = XI(I) - XI(J) + BR = XI(I) + XI(J) + BI = XR(J) - XR(I) + IF ( LINDI ) THEN + AR = HALF*AR + AI = HALF*AI + BR = HALF*BR + BI = HALF*BI + END IF + HELPR = WR*BR - WI*BI + HELPI = WR*BI + WI*BR + XR(I) = AR + HELPR + XI(I) = AI + HELPI + XR(J) = AR - HELPR + XI(J) = HELPI - AI + WHELP = WR + WR = WR + WR*WSTPR - WI*WSTPI + WI = WI + WI*WSTPR + WHELP*WSTPI + 10 CONTINUE +C + RETURN +C *** Last line of DG01NY *** + END diff --git a/mex/sources/libslicot/DG01OD.f b/mex/sources/libslicot/DG01OD.f new file mode 100644 index 000000000..ded9d479f --- /dev/null +++ b/mex/sources/libslicot/DG01OD.f @@ -0,0 +1,357 @@ + SUBROUTINE DG01OD( SCR, WGHT, N, A, W, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the (scrambled) discrete Hartley transform of +C a real signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C SCR CHARACTER*1 +C Indicates whether the signal is scrambled on input or +C on output as follows: +C = 'N': the signal is not scrambled at all; +C = 'I': the input signal is bit-reversed; +C = 'O': the output transform is bit-reversed. +C +C WGHT CHARACTER*1 +C Indicates whether the precomputed weights are available +C or not, as follows: +C = 'A': available; +C = 'N': not available. +C Note that if N > 1 and WGHT = 'N' on entry, then WGHT is +C set to 'A' on exit. +C +C Input/Output Parameters +C +C N (input) INTEGER +C Number of real samples. N must be a power of 2. +C N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry with SCR = 'N' or SCR = 'O', this array must +C contain the input signal. +C On entry with SCR = 'I', this array must contain the +C bit-reversed input signal. +C On exit with SCR = 'N' or SCR = 'I', this array contains +C the Hartley transform of the input signal. +C On exit with SCR = 'O', this array contains the +C bit-reversed Hartley transform. +C +C W (input/output) DOUBLE PRECISION array, +C dimension (N - LOG2(N)) +C On entry with WGHT = 'A', this array must contain the long +C weight vector computed by a previous call of this routine +C with the same value of N. If WGHT = 'N', the contents of +C this array on entry is ignored. +C On exit, this array contains the long weight vector. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine uses a Hartley butterfly algorithm as described +C in [1]. +C +C REFERENCES +C +C [1] Van Loan, Charles. +C Computational frameworks for the fast Fourier transform. +C SIAM, 1992. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable and requires O(N log(N)) +C floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, April 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C KEYWORDS +C +C Digital signal processing, fast Hartley transform, real signals. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, FOUR + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, FOUR = 4.0D0 ) +C .. Scalar Arguments .. + CHARACTER SCR, WGHT + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION A(*), W(*) +C .. Local Scalars .. + INTEGER I, J, L, LEN, M, P1, P2, Q1, Q2, R1, R2, S1, S2, + $ WPOS + LOGICAL LFWD, LSCR, LWGHT + DOUBLE PRECISION CF, SF, T1, T2, TH +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, COS, DBLE, MOD, SIN +C .. Executable Statements .. +C + INFO = 0 + LFWD = LSAME( SCR, 'N' ) .OR. LSAME( SCR, 'I' ) + LSCR = LSAME( SCR, 'I' ) .OR. LSAME( SCR, 'O' ) + LWGHT = LSAME( WGHT, 'A' ) +C +C Test the input scalar arguments. +C + IF( .NOT.( LFWD .OR. LSCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.LWGHT .AND. .NOT.LSAME( WGHT, 'N' ) ) THEN + INFO = -2 + ELSE + M = 0 + J = 0 + IF( N.GE.1 ) THEN + J = N +C WHILE ( MOD( J, 2 ).EQ.0 ) DO + 10 CONTINUE + IF ( MOD( J, 2 ).EQ.0 ) THEN + J = J/2 + M = M + 1 + GO TO 10 + END IF +C END WHILE 10 + IF ( J.NE.1 ) INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DG01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.LE.1 ) + $ RETURN +C + IF ( .NOT. LWGHT ) THEN +C +C Compute the long weight vector via subvector scaling. +C + R1 = 1 + LEN = 1 + TH = FOUR*ATAN( ONE ) / DBLE( N ) +C + DO 30 L = 1, M - 2 + LEN = 2*LEN + TH = TWO*TH + CF = COS(TH) + SF = SIN(TH) + W(R1) = CF + W(R1+1) = SF + R1 = R1 + 2 +C + DO 20 I = 1, LEN - 2, 2 + W(R1) = CF*W(I) - SF*W(I+1) + W(R1+1) = SF*W(I) + CF*W(I+1) + R1 = R1 + 2 + 20 CONTINUE +C + 30 CONTINUE +C + P1 = 3 + Q1 = R1 - 2 +C + DO 50 L = M - 2, 1, -1 +C + DO 40 I = P1, Q1, 4 + W(R1) = W(I) + W(R1+1) = W(I+1) + R1 = R1 + 2 + 40 CONTINUE +C + P1 = Q1 + 4 + Q1 = R1 - 2 + 50 CONTINUE +C + WGHT = 'A' +C + END IF +C + IF ( LFWD .AND. .NOT.LSCR ) THEN +C +C Inplace shuffling of data. +C + J = 1 +C + DO 70 I = 1, N + IF ( J.GT.I ) THEN + T1 = A(I) + A(I) = A(J) + A(J) = T1 + END IF + L = N/2 +C REPEAT + 60 IF ( J.GT.L ) THEN + J = J - L + L = L/2 + IF ( L.GE.2 ) GO TO 60 + END IF +C UNTIL ( L.LT.2 ) + J = J + L + 70 CONTINUE +C + END IF +C + IF ( LFWD ) THEN +C +C Compute Hartley transform with butterfly operators. +C + DO 110 J = 2, N, 2 + T1 = A(J) + A(J) = A(J-1) - T1 + A(J-1) = A(J-1) + T1 + 110 CONTINUE +C + LEN = 1 + WPOS = N - 2*M + 1 +C + DO 140 L = 1, M - 1 + LEN = 2*LEN + P2 = 1 + Q2 = LEN + 1 + R2 = LEN / 2 + 1 + S2 = R2 + Q2 - 1 +C + DO 130 I = 0, N/( 2*LEN ) - 1 + T1 = A(Q2) + A(Q2) = A(P2) - T1 + A(P2) = A(P2) + T1 + T1 = A(S2) + A(S2) = A(R2) - T1 + A(R2) = A(R2) + T1 +C + P1 = P2 + 1 + Q1 = P1 + LEN + R1 = Q1 - 2 + S1 = R1 + LEN +C + DO 120 J = WPOS, WPOS + LEN - 3, 2 + CF = W(J) + SF = W(J+1) + T1 = CF*A(Q1) + SF*A(S1) + T2 = -CF*A(S1) + SF*A(Q1) + A(Q1) = A(P1) - T1 + A(P1) = A(P1) + T1 + A(S1) = A(R1) - T2 + A(R1) = A(R1) + T2 + P1 = P1 + 1 + Q1 = Q1 + 1 + R1 = R1 - 1 + S1 = S1 - 1 + 120 CONTINUE +C + P2 = P2 + 2*LEN + Q2 = Q2 + 2*LEN + R2 = R2 + 2*LEN + S2 = S2 + 2*LEN + 130 CONTINUE +C + WPOS = WPOS - 2*LEN + 2 + 140 CONTINUE +C + ELSE +C +C Compute Hartley transform with transposed butterfly operators. +C + WPOS = 1 + LEN = N +C + DO 230 L = M - 1, 1, -1 + LEN = LEN / 2 + P2 = 1 + Q2 = LEN + 1 + R2 = LEN / 2 + 1 + S2 = R2 + Q2 - 1 +C + DO 220 I = 0, N/( 2*LEN ) - 1 + T1 = A(Q2) + A(Q2) = A(P2) - T1 + A(P2) = A(P2) + T1 + T1 = A(S2) + A(S2) = A(R2) - T1 + A(R2) = A(R2) + T1 +C + P1 = P2 + 1 + Q1 = P1 + LEN + R1 = Q1 - 2 + S1 = R1 + LEN +C + DO 210 J = WPOS, WPOS + LEN - 3, 2 + CF = W(J) + SF = W(J+1) + T1 = A(P1) - A(Q1) + T2 = A(R1) - A(S1) + A(P1) = A(P1) + A(Q1) + A(R1) = A(R1) + A(S1) + A(Q1) = CF*T1 + SF*T2 + A(S1) = -CF*T2 + SF*T1 + P1 = P1 + 1 + Q1 = Q1 + 1 + R1 = R1 - 1 + S1 = S1 - 1 + 210 CONTINUE +C + P2 = P2 + 2*LEN + Q2 = Q2 + 2*LEN + R2 = R2 + 2*LEN + S2 = S2 + 2*LEN + 220 CONTINUE +C + WPOS = WPOS + LEN - 2 + 230 CONTINUE +C + DO 240 J = 2, N, 2 + T1 = A(J) + A(J) = A(J-1) - T1 + A(J-1) = A(J-1) + T1 + 240 CONTINUE +C + END IF + RETURN +C *** Last line of DG01OD *** + END diff --git a/mex/sources/libslicot/DK01MD.f b/mex/sources/libslicot/DK01MD.f new file mode 100644 index 000000000..3ae298675 --- /dev/null +++ b/mex/sources/libslicot/DK01MD.f @@ -0,0 +1,183 @@ + SUBROUTINE DK01MD( TYPE, N, A, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply an anti-aliasing window to a real signal. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPE CHARACTER*1 +C Indicates the type of window to be applied to the signal +C as follows: +C = 'M': Hamming window; +C = 'N': Hann window; +C = 'Q': Quadratic window. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of samples. N >= 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the signal to be +C processed. +C On exit, this array contains the windowing function. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If TYPE = 'M', then a Hamming window is applied to A(1),...,A(N), +C which yields +C _ +C A(i) = (0.54 + 0.46*cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. +C +C If TYPE = 'N', then a Hann window is applied to A(1),...,A(N), +C which yields +C _ +C A(i) = 0.5*(1 + cos(pi*(i-1)/(N-1)))*A(i), i = 1,2,...,N. +C +C If TYPE = 'Q', then a quadratic window is applied to A(1),..., +C A(N), which yields +C _ +C A(i) = (1 - 2*((i-1)/(N-1))**2)*(1 - (i-1)/(N-1))*A(i), +C i = 1,2,...,(N-1)/2+1; +C _ +C A(i) = 2*(1 - ((i-1)/(N-1))**3)*A(i), i = (N-1)/2+2,...,N. +C +C REFERENCES +C +C [1] Rabiner, L.R. and Rader, C.M. +C Digital Signal Processing. +C IEEE Press, 1972. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0( N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine DK01AD by R. Dekeyser, State +C University of Gent, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Digital signal processing, Hamming window, Hann window, real +C signals, windowing. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION PT46, HALF, PT54, ONE, TWO, FOUR + PARAMETER ( PT46=0.46D0, HALF=0.5D0, PT54=0.54D0, + $ ONE = 1.0D0, TWO=2.0D0, FOUR=4.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, N +C .. Array Arguments .. + DOUBLE PRECISION A(*) +C .. Local Scalars .. + LOGICAL MTYPE, MNTYPE, NTYPE + INTEGER I, N1 + DOUBLE PRECISION BUF, FN, TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, COS, DBLE +C .. Executable Statements .. +C + INFO = 0 + MTYPE = LSAME( TYPE, 'M' ) + NTYPE = LSAME( TYPE, 'N' ) + MNTYPE = MTYPE.OR.NTYPE +C +C Test the input scalar arguments. +C + IF( .NOT.MNTYPE .AND. .NOT.LSAME( TYPE, 'Q' ) ) + $ THEN + INFO = -1 + ELSE IF( N.LE.0 ) THEN + INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'DK01MD', -INFO ) + RETURN + END IF +C + FN = DBLE( N-1 ) + IF( MNTYPE ) TEMP = FOUR*ATAN( ONE )/FN +C + IF ( MTYPE ) THEN +C +C Hamming window. +C + DO 10 I = 1, N + A(I) = A(I)*( PT54 + PT46*COS( TEMP*DBLE( I-1 ) ) ) + 10 CONTINUE +C + ELSE IF ( NTYPE ) THEN +C +C Hann window. +C + DO 20 I = 1, N + A(I) = A(I)*HALF*( ONE + COS( TEMP*DBLE( I-1 ) ) ) + 20 CONTINUE +C + ELSE +C +C Quadratic window. +C + N1 = ( N-1 )/2 + 1 +C + DO 30 I = 1, N + BUF = DBLE( I-1 )/FN + TEMP = BUF**2 + IF ( I.LE.N1 ) THEN + A(I) = A(I)*( ONE - TWO*TEMP )*( ONE - BUF ) + ELSE + A(I) = A(I)*TWO*( ONE - BUF*TEMP ) + END IF + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of DK01MD *** + END diff --git a/mex/sources/libslicot/FB01QD.f b/mex/sources/libslicot/FB01QD.f new file mode 100644 index 000000000..4bcc391f9 --- /dev/null +++ b/mex/sources/libslicot/FB01QD.f @@ -0,0 +1,464 @@ + SUBROUTINE FB01QD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, + $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a combined measurement and time update of one +C iteration of the time-varying Kalman filter. This update is given +C for the square root covariance filter, using dense matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBK CHARACTER*1 +C Indicates whether the user wishes to compute the Kalman +C filter gain matrix K as follows: +C i +C = 'K': K is computed and stored in array K; +C i +C = 'N': K is not required. +C i +C +C MULTBQ CHARACTER*1 1/2 +C Indicates how matrices B and Q are to be passed to +C i i +C the routine as follows: +C = 'P': Array Q is not used and the array B must contain +C 1/2 +C the product B Q ; +C i i +C = 'N': Arrays B and Q must contain the matrices as +C described below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C matrices S and A . N >= 0. +C i-1 i +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C 1/2 +C Q . M >= 0. +C i +C +C P (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C 1/2 +C R . P >= 0. +C i +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) +C On entry, the leading N-by-N lower triangular part of this +C array must contain S , the square root (left Cholesky +C i-1 +C factor) of the state covariance matrix at instant (i-1). +C On exit, the leading N-by-N lower triangular part of this +C array contains S , the square root (left Cholesky factor) +C i +C of the state covariance matrix at instant i. +C The strict upper triangular part of this array is not +C referenced. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain A , +C i +C the state transition matrix of the discrete system at +C instant i. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain B , +C 1/2 i +C the input weight matrix (or the product B Q if +C i i +C MULTBQ = 'P') of the discrete system at instant i. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) +C If MULTBQ = 'N', then the leading M-by-M lower triangular +C 1/2 +C part of this array must contain Q , the square root +C i +C (left Cholesky factor) of the input (process) noise +C covariance matrix at instant i. +C The strict upper triangular part of this array is not +C referenced. +C If MULTBQ = 'P', Q is not referenced and can be supplied +C as a dummy array (i.e., set parameter LDQ = 1 and declare +C this array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,M) if MULTBQ = 'N'; +C LDQ >= 1 if MULTBQ = 'P'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain C , the +C i +C output weight matrix of the discrete system at instant i. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) +C On entry, the leading P-by-P lower triangular part of this +C 1/2 +C array must contain R , the square root (left Cholesky +C i +C factor) of the output (measurement) noise covariance +C matrix at instant i. +C On exit, the leading P-by-P lower triangular part of this +C 1/2 +C array contains (RINOV ) , the square root (left Cholesky +C i +C factor) of the covariance matrix of the innovations at +C instant i. +C The strict upper triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,P). +C +C K (output) DOUBLE PRECISION array, dimension (LDK,P) +C If JOBK = 'K', and INFO = 0, then the leading N-by-P part +C of this array contains K , the Kalman filter gain matrix +C i +C at instant i. +C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the +C leading N-by-P part of this array contains AK , a matrix +C i +C related to the Kalman filter gain matrix at instant i (see +C -1/2 +C METHOD). Specifically, AK = A P C'(RINOV') . +C i i i|i-1 i i +C +C LDK INTEGER +C The leading dimension of array K. LDK >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If JOBK = 'K', then TOL is used to test for near +C 1/2 +C singularity of the matrix (RINOV ) . If the user sets +C i +C TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then an implicitly computed, default +C tolerance, defined by TOLDEF = P*P*EPS, is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C Otherwise, TOL is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), +C where LIWORK = P if JOBK = 'K', +C and LIWORK = 1 otherwise. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns +C an estimate of the reciprocal of the condition number +C 1/2 +C (in the 1-norm) of (RINOV ) . +C i +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N*(P+N)+2*P,N*(N+M+2)), if JOBK = 'N'; +C LDWORK >= MAX(2,N*(P+N)+2*P,N*(N+M+2),3*P), if JOBK = 'K'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C 1/2 +C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, +C i 1/2 +C i.e., the condition number estimate of (RINOV ) +C i +C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , +C 1/2 i +C and (RINOV ) have been computed. +C i +C +C METHOD +C +C The routine performs one recursion of the square root covariance +C filter algorithm, summarized as follows: +C +C | 1/2 | | 1/2 | +C | R C x S 0 | | (RINOV ) 0 0 | +C | i i i-1 | | i | +C | 1/2 | T = | | +C | 0 A x S B x Q | | AK S 0 | +C | i i-1 i i | | i i | +C +C (Pre-array) (Post-array) +C +C where T is an orthogonal transformation triangularizing the +C pre-array. +C +C The state covariance matrix P is factorized as +C i|i-1 +C P = S S' +C i|i-1 i i +C +C and one combined time and measurement update for the state X +C i|i-1 +C is given by +C +C X = A X + K (Y - C X ), +C i+1|i i i|i-1 i i i i|i-1 +C +C -1/2 +C where K = AK (RINOV ) is the Kalman filter gain matrix and Y +C i i i i +C is the observed output of the system. +C +C The triangularization is done entirely via Householder +C transformations exploiting the zero pattern of the pre-array. +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering. +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. +C +C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. +C Algorithm 675: FORTRAN Subroutines for Computing the Square +C Root Covariance Filter and Square Root Information Filter in +C Dense or Hessenberg Forms. +C ACM Trans. Math. Software, 15, pp. 243-256, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires +C +C 3 2 2 2 +C (7/6)N + N x (5/2 x P + M) + N x (1/2 x M + P ) +C +C operations and is backward stable (see [2]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01ED by M. Vanbegin, +C P. Van Dooren, and M.H.G. Verhaegen. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003. +C +C KEYWORDS +C +C Kalman filtering, optimal filtering, orthogonal transformation, +C recursive estimation, square-root covariance filtering, +C square-root filtering. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBK, MULTBQ + INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, + $ M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL LJOBK, LMULTB + INTEGER I12, ITAU, JWORK, N1, PN, WRKOPT + DOUBLE PRECISION RCOND +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGELQF, DLACPY, DTRMM, MB02OD, MB04LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + PN = P + N + N1 = MAX( 1, N ) + INFO = 0 + LJOBK = LSAME( JOBK, 'K' ) + LMULTB = LSAME( MULTBQ, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDS.LT.N1 ) THEN + INFO = -7 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -9 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -11 + ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDR.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDK.LT.N1 ) THEN + INFO = -19 + ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + 2*P, + $ N*(N + M + 2), 3*P ) ) .OR. + $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + 2*P, + $ N*(N + M + 2) ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( LJOBK ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + ELSE + DWORK(1) = ONE + END IF + RETURN + END IF +C +C Construction of the needed part of the pre-array in DWORK. +C To save workspace, only the blocks (1,2), (2,2), and (2,3) will be +C constructed as shown below. +C +C Storing A x S and C x S in the (1,1) and (2,1) blocks of DWORK, +C respectively. +C Workspace: need (N+P)*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, PN ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), PN ) + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', PN, N, + $ ONE, S, LDS, DWORK, PN ) +C +C Triangularization (2 steps). +C +C Step 1: annihilate the matrix C x S. +C Workspace: need (N+P)*N + 2*P. +C + ITAU = PN*N + 1 + JWORK = ITAU + P +C + CALL MB04LD( 'Full', P, N, N, R, LDR, DWORK(N+1), PN, DWORK, PN, + $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) + WRKOPT = PN*N + 2*P +C +C Now, the workspace for C x S is no longer needed. +C Adjust the leading dimension of DWORK, to save space for the +C following computations. +C + CALL DLACPY( 'Full', N, N, DWORK, PN, DWORK, N ) + I12 = N*N + 1 +C +C Storing B x Q in the (1,2) block of DWORK. +C Workspace: need N*(N+M). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I12), N ) + IF ( .NOT.LMULTB ) + $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, + $ ONE, Q, LDQ, DWORK(I12), N ) + WRKOPT = MAX( WRKOPT, N*( N + M ) ) +C +C Step 2: LQ triangularization of the matrix [ A x S B x Q ], where +C A x S was modified at Step 1. +C Workspace: need N*(N+M+2); prefer N*(N+M+1)+N*NB. +C + ITAU = N*( N + M ) + 1 + JWORK = ITAU + N +C + CALL DGELQF( N, N+M, DWORK, N, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Output S and K (if needed) and set the optimal workspace +C dimension (and the reciprocal of the condition number estimate). +C + CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) +C + IF ( LJOBK ) THEN +C +C Compute K. +C Workspace: need 3*P. +C + CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', + $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, + $ IWORK, DWORK, INFO ) + IF ( INFO.EQ.0 ) THEN + WRKOPT = MAX( WRKOPT, 3*P ) + DWORK(2) = RCOND + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of FB01QD *** + END diff --git a/mex/sources/libslicot/FB01RD.f b/mex/sources/libslicot/FB01RD.f new file mode 100644 index 000000000..721cb2ae7 --- /dev/null +++ b/mex/sources/libslicot/FB01RD.f @@ -0,0 +1,535 @@ + SUBROUTINE FB01RD( JOBK, MULTBQ, N, M, P, S, LDS, A, LDA, B, + $ LDB, Q, LDQ, C, LDC, R, LDR, K, LDK, TOL, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a combined measurement and time update of one +C iteration of the time-invariant Kalman filter. This update is +C given for the square root covariance filter, using the condensed +C observer Hessenberg form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBK CHARACTER*1 +C Indicates whether the user wishes to compute the Kalman +C filter gain matrix K as follows: +C i +C = 'K': K is computed and stored in array K; +C i +C = 'N': K is not required. +C i +C +C MULTBQ CHARACTER*1 1/2 +C Indicates how matrices B and Q are to be passed to +C i i +C the routine as follows: +C = 'P': Array Q is not used and the array B must contain +C 1/2 +C the product B Q ; +C i i +C = 'N': Arrays B and Q must contain the matrices as +C described below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C matrices S and A. N >= 0. +C i-1 +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C 1/2 +C Q . M >= 0. +C i +C +C P (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C 1/2 +C R . P >= 0. +C i +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) +C On entry, the leading N-by-N lower triangular part of this +C array must contain S , the square root (left Cholesky +C i-1 +C factor) of the state covariance matrix at instant (i-1). +C On exit, the leading N-by-N lower triangular part of this +C array contains S , the square root (left Cholesky factor) +C i +C of the state covariance matrix at instant i. +C The strict upper triangular part of this array is not +C referenced. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain A, +C the state transition matrix of the discrete system in +C lower observer Hessenberg form (e.g., as produced by +C SLICOT Library Routine TB01ND). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain B , +C 1/2 i +C the input weight matrix (or the product B Q if +C i i +C MULTBQ = 'P') of the discrete system at instant i. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,*) +C If MULTBQ = 'N', then the leading M-by-M lower triangular +C 1/2 +C part of this array must contain Q , the square root +C i +C (left Cholesky factor) of the input (process) noise +C covariance matrix at instant i. +C The strict upper triangular part of this array is not +C referenced. +C Otherwise, Q is not referenced and can be supplied as a +C dummy array (i.e., set parameter LDQ = 1 and declare this +C array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,M) if MULTBQ = 'N'; +C LDQ >= 1 if MULTBQ = 'P'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain C, +C the output weight matrix of the discrete system in lower +C observer Hessenberg form (e.g., as produced by SLICOT +C Library routine TB01ND). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,P) +C On entry, the leading P-by-P lower triangular part of this +C 1/2 +C array must contain R , the square root (left Cholesky +C i +C factor) of the output (measurement) noise covariance +C matrix at instant i. +C On exit, the leading P-by-P lower triangular part of this +C 1/2 +C array contains (RINOV ) , the square root (left Cholesky +C i +C factor) of the covariance matrix of the innovations at +C instant i. +C The strict upper triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,P). +C +C K (output) DOUBLE PRECISION array, dimension (LDK,P) +C If JOBK = 'K', and INFO = 0, then the leading N-by-P part +C of this array contains K , the Kalman filter gain matrix +C i +C at instant i. +C If JOBK = 'N', or JOBK = 'K' and INFO = 1, then the +C leading N-by-P part of this array contains AK , a matrix +C i +C related to the Kalman filter gain matrix at instant i (see +C -1/2 +C METHOD). Specifically, AK = A P C'(RINOV') . +C i i|i-1 i +C +C LDK INTEGER +C The leading dimension of array K. LDK >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If JOBK = 'K', then TOL is used to test for near +C 1/2 +C singularity of the matrix (RINOV ) . If the user sets +C i +C TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then an implicitly computed, default +C tolerance, defined by TOLDEF = P*P*EPS, is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C Otherwise, TOL is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C where LIWORK = P if JOBK = 'K', +C and LIWORK = 1 otherwise. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If INFO = 0 and JOBK = 'K', DWORK(2) returns +C an estimate of the reciprocal of the condition number +C 1/2 +C (in the 1-norm) of (RINOV ) . +C i +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2)), +C if JOBK = 'N'; +C LDWORK >= MAX(2,N*(P+N+1),N*(P+N)+2*P,N*(N+M+2),3*P), +C if JOBK = 'K'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C 1/2 +C = 1: if JOBK = 'K' and the matrix (RINOV ) is singular, +C i 1/2 +C i.e., the condition number estimate of (RINOV ) +C i +C (in the 1-norm) exceeds 1/TOL. The matrices S, AK , +C 1/2 i +C and (RINOV ) have been computed. +C i +C +C METHOD +C +C The routine performs one recursion of the square root covariance +C filter algorithm, summarized as follows: +C +C | 1/2 | | 1/2 | +C | R 0 C x S | | (RINOV ) 0 0 | +C | i i-1 | | i | +C | 1/2 | T = | | +C | 0 B x Q A x S | | AK S 0 | +C | i i i-1 | | i i | +C +C (Pre-array) (Post-array) +C +C where T is unitary and (A,C) is in lower observer Hessenberg form. +C +C An example of the pre-array is given below (where N = 6, P = 2 +C and M = 3): +C +C |x | | x | +C |x x | | x x | +C |____|______|____________| +C | | x x x| x x x | +C | | x x x| x x x x | +C | | x x x| x x x x x | +C | | x x x| x x x x x x| +C | | x x x| x x x x x x| +C | | x x x| x x x x x x| +C +C The corresponding state covariance matrix P is then +C i|i-1 +C factorized as +C +C P = S S' +C i|i-1 i i +C +C and one combined time and measurement update for the state X +C i|i-1 +C is given by +C +C X = A X + K (Y - C X ) +C i+1|i i|i-1 i i i|i-1 +C +C -1/2 +C where K = AK (RINOV ) is the Kalman filter gain matrix and Y +C i i i i +C is the observed output of the system. +C +C The triangularization is done entirely via Householder +C transformations exploiting the zero pattern of the pre-array. +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering. +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Van Dooren, P. and Verhaegen, M.H.G. +C Condensed Forms for Efficient Time-Invariant Kalman Filtering. +C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. +C +C [3] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. +C +C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. +C Algorithm 675: FORTRAN Subroutines for Computing the Square +C Root Covariance Filter and Square Root Information Filter in +C Dense or Hessenberg Forms. +C ACM Trans. Math. Software, 15, pp. 243-256, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires +C +C 3 2 2 3 +C 1/6 x N + N x (3/2 x P + M) + 2 x N x P + 2/3 x P +C +C operations and is backward stable (see [3]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01FD by M. Vanbegin, +C P. Van Dooren, and M.H.G. Verhaegen. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003, February 14, 2004. +C +C KEYWORDS +C +C Kalman filtering, observer Hessenberg form, optimal filtering, +C orthogonal transformation, recursive estimation, square-root +C covariance filtering, square-root filtering. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBK, MULTBQ + INTEGER INFO, LDA, LDB, LDC, LDK, LDQ, LDR, LDS, LDWORK, + $ M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ K(LDK,*), Q(LDQ,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL LJOBK, LMULTB + INTEGER I, II, ITAU, JWORK, N1, PL, PN, WRKOPT + DOUBLE PRECISION RCOND +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, MB04JD, + $ MB04LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + PN = P + N + N1 = MAX( 1, N ) + INFO = 0 + LJOBK = LSAME( JOBK, 'K' ) + LMULTB = LSAME( MULTBQ, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBK .AND. .NOT.LSAME( JOBK, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LMULTB .AND. .NOT.LSAME( MULTBQ, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDS.LT.N1 ) THEN + INFO = -7 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -9 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -11 + ELSE IF( LDQ.LT.1 .OR. ( .NOT.LMULTB .AND. LDQ.LT.M ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDR.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDK.LT.N1 ) THEN + INFO = -19 + ELSE IF( ( LJOBK .AND. LDWORK.LT.MAX( 2, PN*N + N, PN*N + 2*P, + $ N*(N + M + 2), 3*P ) ) .OR. + $ ( .NOT.LJOBK .AND. LDWORK.LT.MAX( 1, PN*N + N, PN*N + 2*P, + $ N*(N + M + 2) ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( LJOBK ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + ELSE + DWORK(1) = ONE + END IF + RETURN + END IF +C +C Construction of the needed part of the pre-array in DWORK. +C To save workspace, only the blocks (1,3), (2,2), and (2,3) will be +C constructed as shown below. +C +C Storing C x S and A x S in the (1,1) and (2,1) blocks of DWORK, +C respectively. The lower trapezoidal structure of [ C' A' ]' is +C fully exploited. Specifically, if P <= N, the following partition +C is used: +C +C [ C1 0 ] [ S1 0 ] +C [ A1 A3 ] [ S2 S3 ], +C [ A2 A4 ] +C +C where C1, S1, and A2 are P-by-P matrices, A1 and S2 are +C (N-P)-by-P, A3 and S3 are (N-P)-by-(N-P), A4 is P-by-(N-P), and +C C1, S1, A3, and S3 are lower triangular. The left hand side +C matrix above is stored in the workspace. If P > N, the partition +C is: +C +C [ C1 ] +C [ C2 ] [ S ], +C [ A ] +C +C where C1 and C2 are N-by-N and (P-N)-by-N matrices, respectively, +C and C1 and S are lower triangular. +C +C Workspace: need (P+N)*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DLACPY( 'Lower', P, MIN( N, P ), C, LDC, DWORK, PN ) + CALL DLACPY( 'Full', N, MIN( N, P ), A, LDA, DWORK(P+1), PN ) + IF ( N.GT.P ) + $ CALL DLACPY( 'Lower', N, N-P, A(1,P+1), LDA, DWORK(P*PN+P+1), + $ PN ) +C +C [ C1 0 ] +C Compute [ ] x S or C1 x S as a product of lower triangular +C [ A1 A3 ] +C matrices. +C Workspace: need (P+N+1)*N. +C + II = 1 + PL = N*PN + 1 + WRKOPT = PL + N - 1 +C + DO 10 I = 1, N + CALL DCOPY( N-I+1, S(I,I), 1, DWORK(PL), 1 ) + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', N-I+1, + $ DWORK(II), PN, DWORK(PL), 1 ) + CALL DCOPY( N-I+1, DWORK(PL), 1, DWORK(II), 1 ) + II = II + PN + 1 + 10 CONTINUE +C +C Compute [ A2 A4 ] x S. +C + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', P, N, + $ ONE, S, LDS, DWORK(N+1), PN ) +C +C Triangularization (2 steps). +C +C Step 1: annihilate the matrix C x S (hence C1 x S1, if P <= N). +C Workspace: need (N+P)*N + 2*P. +C + ITAU = PL + JWORK = ITAU + P +C + CALL MB04LD( 'Lower', P, N, N, R, LDR, DWORK, PN, DWORK(P+1), PN, + $ K, LDK, DWORK(ITAU), DWORK(JWORK) ) + WRKOPT = MAX( WRKOPT, PN*N + 2*P ) +C +C Now, the workspace for C x S is no longer needed. +C Adjust the leading dimension of DWORK, to save space for the +C following computations, and make room for B x Q. +C + CALL DLACPY( 'Full', N, N, DWORK(P+1), PN, DWORK, N ) +C + DO 20 I = N*( N - 1 ) + 1, 1, -N + CALL DCOPY( N, DWORK(I), 1, DWORK(I+N*M), 1 ) + 20 CONTINUE +C +C Storing B x Q in the (1,1) block of DWORK. +C Workspace: need N*(M+N). +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + IF ( .NOT.LMULTB ) + $ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Non-unit', N, M, + $ ONE, Q, LDQ, DWORK, N ) +C +C Step 2: LQ triangularization of the matrix [ B x Q A x S ], where +C A x S was modified at Step 1. +C Workspace: need N*(N+M+2); +C prefer N*(N+M+1)+(P+1)*NB, where NB is the optimal +C block size for DGELQF (called in MB04JD). +C + ITAU = N*( M + N ) + 1 + JWORK = ITAU + N +C + CALL MB04JD( N, M+N, MAX( N-P-1, 0 ), 0, DWORK, N, DWORK, N, + $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Output S and K (if needed) and set the optimal workspace +C dimension (and the reciprocal of the condition number estimate). +C + CALL DLACPY( 'Lower', N, N, DWORK, N, S, LDS ) +C + IF ( LJOBK ) THEN +C +C Compute K. +C Workspace: need 3*P. +C + CALL MB02OD( 'Right', 'Lower', 'No transpose', 'Non-unit', + $ '1-norm', N, P, ONE, R, LDR, K, LDK, RCOND, TOL, + $ IWORK, DWORK, INFO ) + IF ( INFO.EQ.0 ) THEN + WRKOPT = MAX( WRKOPT, 3*P ) + DWORK(2) = RCOND + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of FB01RD *** + END diff --git a/mex/sources/libslicot/FB01SD.f b/mex/sources/libslicot/FB01SD.f new file mode 100644 index 000000000..41783fc2e --- /dev/null +++ b/mex/sources/libslicot/FB01SD.f @@ -0,0 +1,597 @@ + SUBROUTINE FB01SD( JOBX, MULTAB, MULTRC, N, M, P, SINV, LDSINV, + $ AINV, LDAINV, B, LDB, RINV, LDRINV, C, LDC, + $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a combined measurement and time update of one +C iteration of the time-varying Kalman filter. This update is given +C for the square root information filter, using dense matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX CHARACTER*1 +C Indicates whether X is to be computed as follows: +C i+1 +C = 'X': X is computed and stored in array X; +C i+1 +C = 'N': X is not required. +C i+1 +C +C MULTAB CHARACTER*1 -1 +C Indicates how matrices A and B are to be passed to +C i i +C the routine as follows: -1 +C = 'P': Array AINV must contain the matrix A and the +C -1 i +C array B must contain the product A B ; +C i i +C = 'N': Arrays AINV and B must contain the matrices +C as described below. +C +C MULTRC CHARACTER*1 -1/2 +C Indicates how matrices R and C are to be passed to +C i+1 i+1 +C the routine as follows: +C = 'P': Array RINV is not used and the array C must +C -1/2 +C contain the product R C ; +C i+1 i+1 +C = 'N': Arrays RINV and C must contain the matrices +C as described below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C -1 -1 +C matrices S and A . N >= 0. +C i i +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C -1/2 +C Q . M >= 0. +C i +C +C P (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C -1/2 +C R . P >= 0. +C i+1 +C +C SINV (input/output) DOUBLE PRECISION array, dimension +C (LDSINV,N) +C On entry, the leading N-by-N upper triangular part of this +C -1 +C array must contain S , the inverse of the square root +C i +C (right Cholesky factor) of the state covariance matrix +C P (hence the information square root) at instant i. +C i|i +C On exit, the leading N-by-N upper triangular part of this +C -1 +C array contains S , the inverse of the square root (right +C i+1 +C Cholesky factor) of the state covariance matrix P +C i+1|i+1 +C (hence the information square root) at instant i+1. +C The strict lower triangular part of this array is not +C referenced. +C +C LDSINV INTEGER +C The leading dimension of array SINV. LDSINV >= MAX(1,N). +C +C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) +C -1 +C The leading N-by-N part of this array must contain A , +C i +C the inverse of the state transition matrix of the discrete +C system at instant i. +C +C LDAINV INTEGER +C The leading dimension of array AINV. LDAINV >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain B , +C -1 i +C the input weight matrix (or the product A B if +C i i +C MULTAB = 'P') of the discrete system at instant i. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) +C If MULTRC = 'N', then the leading P-by-P upper triangular +C -1/2 +C part of this array must contain R , the inverse of the +C i+1 +C covariance square root (right Cholesky factor) of the +C output (measurement) noise (hence the information square +C root) at instant i+1. +C The strict lower triangular part of this array is not +C referenced. +C Otherwise, RINV is not referenced and can be supplied as a +C dummy array (i.e., set parameter LDRINV = 1 and declare +C this array to be RINV(1,1) in the calling program). +C +C LDRINV INTEGER +C The leading dimension of array RINV. +C LDRINV >= MAX(1,P) if MULTRC = 'N'; +C LDRINV >= 1 if MULTRC = 'P'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain C , +C -1/2 i+1 +C the output weight matrix (or the product R C if +C i+1 i+1 +C MULTRC = 'P') of the discrete system at instant i+1. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C QINV (input/output) DOUBLE PRECISION array, dimension +C (LDQINV,M) +C On entry, the leading M-by-M upper triangular part of this +C -1/2 +C array must contain Q , the inverse of the covariance +C i +C square root (right Cholesky factor) of the input (process) +C noise (hence the information square root) at instant i. +C On exit, the leading M-by-M upper triangular part of this +C -1/2 +C array contains (QINOV ) , the inverse of the covariance +C i +C square root (right Cholesky factor) of the process noise +C innovation (hence the information square root) at +C instant i. +C The strict lower triangular part of this array is not +C referenced. +C +C LDQINV INTEGER +C The leading dimension of array QINV. LDQINV >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain X , the estimated +C i +C filtered state at instant i. +C On exit, if JOBX = 'X', and INFO = 0, then this array +C contains X , the estimated filtered state at +C i+1 +C instant i+1. +C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then +C -1 +C this array contains S X . +C i+1 i+1 +C +C RINVY (input) DOUBLE PRECISION array, dimension (P) +C -1/2 +C This array must contain R Y , the product of the +C i+1 i+1 +C -1/2 +C upper triangular matrix R and the measured output +C i+1 +C vector Y at instant i+1. +C i+1 +C +C Z (input) DOUBLE PRECISION array, dimension (M) +C This array must contain Z , the mean value of the state +C i +C process noise at instant i. +C +C E (output) DOUBLE PRECISION array, dimension (P) +C This array contains E , the estimated error at instant +C i+1 +C i+1. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If JOBX = 'X', then TOL is used to test for near +C -1 +C singularity of the matrix S . If the user sets +C i+1 +C TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then an implicitly computed, default +C tolerance, defined by TOLDEF = N*N*EPS, is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C Otherwise, TOL is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C where LIWORK = N if JOBX = 'X', +C and LIWORK = 1 otherwise. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns +C an estimate of the reciprocal of the condition number +C -1 +C (in the 1-norm) of S . +C i+1 +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N), +C if JOBX = 'N'; +C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+2*N,3*N), +C if JOBX = 'X'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; -1 +C = 1: if JOBX = 'X' and the matrix S is singular, +C i+1 -1 +C i.e., the condition number estimate of S (in the +C i+1 +C -1 -1/2 +C 1-norm) exceeds 1/TOL. The matrices S , Q +C i+1 i +C and E have been computed. +C +C METHOD +C +C The routine performs one recursion of the square root information +C filter algorithm, summarized as follows: +C +C | -1/2 -1/2 | | -1/2 | +C | Q 0 Q Z | | (QINOV ) * * | +C | i i i | | i | +C | | | | +C | -1 -1 -1 -1 -1 | | -1 -1 | +C T | S A B S A S X | = | 0 S S X | +C | i i i i i i i | | i+1 i+1 i+1| +C | | | | +C | -1/2 -1/2 | | | +C | 0 R C R Y | | 0 0 E | +C | i+1 i+1 i+1 i+1| | i+1 | +C +C (Pre-array) (Post-array) +C +C where T is an orthogonal transformation triangularizing the +C -1/2 +C pre-array, (QINOV ) is the inverse of the covariance square +C i +C root (right Cholesky factor) of the process noise innovation +C (hence the information square root) at instant i, and E is the +C i+1 +C estimated error at instant i+1. +C +C The inverse of the corresponding state covariance matrix P +C i+1|i+1 +C (hence the information matrix I) is then factorized as +C +C -1 -1 -1 +C I = P = (S )' S +C i+1|i+1 i+1|i+1 i+1 i+1 +C +C and one combined time and measurement update for the state is +C given by X . +C i+1 +C +C The triangularization is done entirely via Householder +C transformations exploiting the zero pattern of the pre-array. +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering. +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. +C +C [3] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. +C Algorithm 675: FORTRAN Subroutines for Computing the Square +C Root Covariance Filter and Square Root Information Filter in +C Dense or Hessenberg Forms. +C ACM Trans. Math. Software, 15, pp. 243-256, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 3 2 2 2 +C (7/6)N + N x (7/2 x M + P) + N x (1/2 x P + M ) +C +C operations and is backward stable (see [2]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01GD by M. Vanbegin, +C P. Van Dooren, and M.H.G. Verhaegen. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003, February 14, 2004. +C +C KEYWORDS +C +C Kalman filtering, optimal filtering, orthogonal transformation, +C recursive estimation, square-root filtering, square-root +C information filtering. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBX, MULTAB, MULTRC + INTEGER INFO, LDAINV, LDB, LDC, LDQINV, LDRINV, LDSINV, + $ LDWORK, M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION AINV(LDAINV,*), B(LDB,*), C(LDC,*), DWORK(*), + $ E(*), QINV(LDQINV,*), RINV(LDRINV,*), RINVY(*), + $ SINV(LDSINV,*), X(*), Z(*) +C .. Local Scalars .. + LOGICAL LJOBX, LMULTA, LMULTR + INTEGER I, I12, I13, I21, I23, IJ, ITAU, JWORK, LDW, M1, + $ N1, NP, WRKOPT + DOUBLE PRECISION RCOND +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DLACPY, DORMQR, + $ DTRMM, DTRMV, MB02OD, MB04KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + NP = N + P + N1 = MAX( 1, N ) + M1 = MAX( 1, M ) + INFO = 0 + LJOBX = LSAME( JOBX, 'X' ) + LMULTA = LSAME( MULTAB, 'P' ) + LMULTR = LSAME( MULTRC, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LMULTA .AND. .NOT.LSAME( MULTAB, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDSINV.LT.N1 ) THEN + INFO = -8 + ELSE IF( LDAINV.LT.N1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -12 + ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDQINV.LT.M1 ) THEN + INFO = -18 + ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(N + 2*M) + 3*M, + $ NP*(N + 1) + 2*N, 3*N ) ) + $ .OR. + $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(N + 2*M) + 3*M, + $ NP*(N + 1) + 2*N ) ) ) THEN + INFO = -26 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, P ).EQ.0 ) THEN + IF ( LJOBX ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + ELSE + DWORK(1) = ONE + END IF + RETURN + END IF +C +C Construction of the needed part of the pre-array in DWORK. +C To save workspace, only the blocks (1,3), (2,1)-(2,3), (3,2), and +C (3,3) will be constructed when needed as shown below. +C +C Storing SINV x AINV and SINV x AINV x B in the (1,1) and (1,2) +C blocks of DWORK, respectively. +C The variables called Ixy define the starting positions where the +C (x,y) blocks of the pre-array are initially stored in DWORK. +C Workspace: need N*(N+M). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + LDW = N1 + I21 = N*N + 1 +C + CALL DLACPY( 'Full', N, N, AINV, LDAINV, DWORK, LDW ) + IF ( LMULTA ) THEN + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(I21), LDW ) + ELSE + CALL DGEMM( 'No transpose', 'No transpose', N, M, N, ONE, + $ DWORK, LDW, B, LDB, ZERO, DWORK(I21), LDW ) + END IF + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, N+M, + $ ONE, SINV, LDSINV, DWORK, LDW ) +C +C Storing the process noise mean value in (1,3) block of DWORK. +C Workspace: need N*(N+M) + M. +C + I13 = N*( N + M ) + 1 +C + CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, + $ DWORK(I13), 1 ) +C +C Computing SINV x X in X. +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, + $ X, 1 ) +C +C Triangularization (2 steps). +C +C Step 1: annihilate the matrix SINV x AINV x B. +C Workspace: need N*(N+2*M) + 3*M. +C + I12 = I13 + M + ITAU = I12 + M*N + JWORK = ITAU + M +C + CALL MB04KD( 'Full', M, N, N, QINV, LDQINV, DWORK(I21), LDW, + $ DWORK, LDW, DWORK(I12), M1, DWORK(ITAU), + $ DWORK(JWORK) ) + WRKOPT = MAX( 1, N*( N + 2*M ) + 3*M ) +C + IF ( N.EQ.0 ) THEN + CALL DCOPY( P, RINVY, 1, E, 1 ) + IF ( LJOBX ) + $ DWORK(2) = ONE + DWORK(1) = WRKOPT + RETURN + END IF +C +C Apply the transformations to the last column of the pre-array. +C (Only the updated (2,3) block is now needed.) +C + IJ = I21 +C + DO 10 I = 1, M + CALL DAXPY( N, -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + + $ DDOT( N, DWORK(IJ), 1, X, 1 ) ), + $ DWORK(IJ), 1, X, 1 ) + IJ = IJ + N + 10 CONTINUE +C +C Now, the workspace for SINV x AINV x B, as well as for the updated +C (1,2) block of the pre-array, are no longer needed. +C Move the computed (2,3) block of the pre-array in the (1,2) block +C position of DWORK, to save space for the following computations. +C Then, adjust the implicitly defined leading dimension of DWORK, +C to make space for storing the (3,2) and (3,3) blocks of the +C pre-array. +C Workspace: need (N+P)*(N+1). +C + CALL DCOPY( N, X, 1, DWORK(I21), 1 ) + LDW = MAX( 1, NP ) +C + DO 30 I = N + 1, 1, -1 + DO 20 IJ = N, 1, -1 + DWORK(NP*(I-1)+IJ) = DWORK(N*(I-1)+IJ) + 20 CONTINUE + 30 CONTINUE +C +C Copy of RINV x C in the (2,1) block of DWORK. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(N+1), LDW ) + IF ( .NOT.LMULTR ) + $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, + $ ONE, RINV, LDRINV, DWORK(N+1), LDW ) +C +C Copy the inclusion measurement in the (2,2) block of DWORK. +C + I21 = NP*N + 1 + I23 = I21 + N + CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) + WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) +C +C Step 2: QR factorization of the first block column of the matrix +C +C [ SINV x AINV SINV x X ] +C [ RINV x C RINV x Y ], +C +C where the first block row was modified at Step 1. +C Workspace: need (N+P)*(N+1) + 2*N; +C prefer (N+P)*(N+1) + N + N*NB. +C + ITAU = I21 + NP + JWORK = ITAU + N +C + CALL DGEQRF( NP, N, DWORK, LDW, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Apply the Householder transformations to the last column. +C Workspace: need (N+P)*(N+1) + 1; prefer (N+P)*(N+1) + NB. +C + CALL DORMQR( 'Left', 'Transpose', NP, 1, N, DWORK, LDW, + $ DWORK(ITAU), DWORK(I21), LDW, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Output SINV, X, and E and set the optimal workspace dimension +C (and the reciprocal of the condition number estimate). +C + CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) + CALL DCOPY( N, DWORK(I21), 1, X, 1 ) + CALL DCOPY( P, DWORK(I23), 1, E, 1 ) +C + IF ( LJOBX ) THEN +C +C Compute X. +C Workspace: need 3*N. +C + CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', + $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, + $ TOL, IWORK, DWORK, INFO ) + IF ( INFO.EQ.0 ) THEN + WRKOPT = MAX( WRKOPT, 3*N ) + DWORK(2) = RCOND + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of FB01SD *** + END diff --git a/mex/sources/libslicot/FB01TD.f b/mex/sources/libslicot/FB01TD.f new file mode 100644 index 000000000..f248de0d9 --- /dev/null +++ b/mex/sources/libslicot/FB01TD.f @@ -0,0 +1,641 @@ + SUBROUTINE FB01TD( JOBX, MULTRC, N, M, P, SINV, LDSINV, AINV, + $ LDAINV, AINVB, LDAINB, RINV, LDRINV, C, LDC, + $ QINV, LDQINV, X, RINVY, Z, E, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a combined measurement and time update of one +C iteration of the time-invariant Kalman filter. This update is +C given for the square root information filter, using the condensed +C controller Hessenberg form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX CHARACTER*1 +C Indicates whether X is to be computed as follows: +C i+1 +C = 'X': X is computed and stored in array X; +C i+1 +C = 'N': X is not required. +C i+1 +C +C MULTRC CHARACTER*1 -1/2 +C Indicates how matrices R and C are to be passed to +C i+1 i+1 +C the routine as follows: +C = 'P': Array RINV is not used and the array C must +C -1/2 +C contain the product R C ; +C i+1 i+1 +C = 'N': Arrays RINV and C must contain the matrices +C as described below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C -1 -1 +C matrices S and A . N >= 0. +C i +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C -1/2 +C Q . M >= 0. +C i +C +C P (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C -1/2 +C R . P >= 0. +C i+1 +C +C SINV (input/output) DOUBLE PRECISION array, dimension +C (LDSINV,N) +C On entry, the leading N-by-N upper triangular part of this +C -1 +C array must contain S , the inverse of the square root +C i +C (right Cholesky factor) of the state covariance matrix +C P (hence the information square root) at instant i. +C i|i +C On exit, the leading N-by-N upper triangular part of this +C -1 +C array contains S , the inverse of the square root (right +C i+1 +C Cholesky factor) of the state covariance matrix P +C i+1|i+1 +C (hence the information square root) at instant i+1. +C The strict lower triangular part of this array is not +C referenced. +C +C LDSINV INTEGER +C The leading dimension of array SINV. LDSINV >= MAX(1,N). +C +C AINV (input) DOUBLE PRECISION array, dimension (LDAINV,N) +C -1 +C The leading N-by-N part of this array must contain A , +C the inverse of the state transition matrix of the discrete +C system in controller Hessenberg form (e.g., as produced by +C SLICOT Library Routine TB01MD). +C +C LDAINV INTEGER +C The leading dimension of array AINV. LDAINV >= MAX(1,N). +C +C AINVB (input) DOUBLE PRECISION array, dimension (LDAINB,M) +C -1 +C The leading N-by-M part of this array must contain A B, +C -1 +C the product of A and the input weight matrix B of the +C discrete system, in upper controller Hessenberg form +C (e.g., as produced by SLICOT Library Routine TB01MD). +C +C LDAINB INTEGER +C The leading dimension of array AINVB. LDAINB >= MAX(1,N). +C +C RINV (input) DOUBLE PRECISION array, dimension (LDRINV,*) +C If MULTRC = 'N', then the leading P-by-P upper triangular +C -1/2 +C part of this array must contain R , the inverse of the +C i+1 +C covariance square root (right Cholesky factor) of the +C output (measurement) noise (hence the information square +C root) at instant i+1. +C The strict lower triangular part of this array is not +C referenced. +C Otherwise, RINV is not referenced and can be supplied as a +C dummy array (i.e., set parameter LDRINV = 1 and declare +C this array to be RINV(1,1) in the calling program). +C +C LDRINV INTEGER +C The leading dimension of array RINV. +C LDRINV >= MAX(1,P) if MULTRC = 'N'; +C LDRINV >= 1 if MULTRC = 'P'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain C , +C -1/2 i+1 +C the output weight matrix (or the product R C if +C i+1 i+1 +C MULTRC = 'P') of the discrete system at instant i+1. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C QINV (input/output) DOUBLE PRECISION array, dimension +C (LDQINV,M) +C On entry, the leading M-by-M upper triangular part of this +C -1/2 +C array must contain Q , the inverse of the covariance +C i +C square root (right Cholesky factor) of the input (process) +C noise (hence the information square root) at instant i. +C On exit, the leading M-by-M upper triangular part of this +C -1/2 +C array contains (QINOV ) , the inverse of the covariance +C i +C square root (right Cholesky factor) of the process noise +C innovation (hence the information square root) at +C instant i. +C The strict lower triangular part of this array is not +C referenced. +C +C LDQINV INTEGER +C The leading dimension of array QINV. LDQINV >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain X , the estimated +C i +C filtered state at instant i. +C On exit, if JOBX = 'X', and INFO = 0, then this array +C contains X , the estimated filtered state at +C i+1 +C instant i+1. +C On exit, if JOBX = 'N', or JOBX = 'X' and INFO = 1, then +C -1 +C this array contains S X . +C i+1 i+1 +C +C RINVY (input) DOUBLE PRECISION array, dimension (P) +C -1/2 +C This array must contain R Y , the product of the +C i+1 i+1 +C -1/2 +C upper triangular matrix R and the measured output +C i+1 +C vector Y at instant i+1. +C i+1 +C +C Z (input) DOUBLE PRECISION array, dimension (M) +C This array must contain Z , the mean value of the state +C i +C process noise at instant i. +C +C E (output) DOUBLE PRECISION array, dimension (P) +C This array contains E , the estimated error at instant +C i+1 +C i+1. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If JOBX = 'X', then TOL is used to test for near +C -1 +C singularity of the matrix S . If the user sets +C i+1 +C TOL > 0, then the given value of TOL is used as a +C lower bound for the reciprocal condition number of that +C matrix; a matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. If the user +C sets TOL <= 0, then an implicitly computed, default +C tolerance, defined by TOLDEF = N*N*EPS, is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C Otherwise, TOL is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C where LIWORK = N if JOBX = 'X', +C and LIWORK = 1 otherwise. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If INFO = 0 and JOBX = 'X', DWORK(2) returns +C an estimate of the reciprocal of the condition number +C -1 +C (in the 1-norm) of S . +C i+1 +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1)), +C if JOBX = 'N'; +C LDWORK >= MAX(2,N*(N+2*M)+3*M,(N+P)*(N+1)+N+MAX(N-1,M+1), +C 3*N), if JOBX = 'X'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; -1 +C = 1: if JOBX = 'X' and the matrix S is singular, +C i+1 -1 +C i.e., the condition number estimate of S (in the +C i+1 +C -1 -1/2 +C 1-norm) exceeds 1/TOL. The matrices S , Q +C i+1 i +C and E have been computed. +C +C METHOD +C +C The routine performs one recursion of the square root information +C filter algorithm, summarized as follows: +C +C | -1/2 -1/2 | | -1/2 | +C | Q 0 Q Z | | (QINOV ) * * | +C | i i i | | i | +C | | | | +C | -1/2 -1/2 | | -1 -1 | +C T | 0 R C R Y | = | 0 S S X | +C | i+1 i+1 i+1 i+1| | i+1 i+1 i+1| +C | | | | +C | -1 -1 -1 -1 -1 | | | +C | S A B S A S X | | 0 0 E | +C | i i i i | | i+1 | +C +C (Pre-array) (Post-array) +C +C where T is an orthogonal transformation triangularizing the +C -1/2 +C pre-array, (QINOV ) is the inverse of the covariance square +C i +C root (right Cholesky factor) of the process noise innovation +C -1 -1 +C (hence the information square root) at instant i and (A ,A B) is +C in upper controller Hessenberg form. +C +C An example of the pre-array is given below (where N = 6, M = 2, +C and P = 3): +C +C |x x | | x| +C | x | | x| +C _______________________ +C | | x x x x x x | x| +C | | x x x x x x | x| +C | | x x x x x x | x| +C _______________________ +C |x x | x x x x x x | x| +C | x | x x x x x x | x| +C | | x x x x x x | x| +C | | x x x x x | x| +C | | x x x x | x| +C | | x x x | x| +C +C The inverse of the corresponding state covariance matrix P +C i+1|i+1 +C (hence the information matrix I) is then factorized as +C +C -1 -1 -1 +C I = P = (S )' S +C i+1|i+1 i+1|i+1 i+1 i+1 +C +C and one combined time and measurement update for the state is +C given by X . +C i+1 +C +C The triangularization is done entirely via Householder +C transformations exploiting the zero pattern of the pre-array. +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering. +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Van Dooren, P. and Verhaegen, M.H.G. +C Condensed Forms for Efficient Time-Invariant Kalman Filtering. +C SIAM J. Sci. Stat. Comp., 9. pp. 516-530, 1988. +C +C [3] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, Oct. 1986. +C +C [4] Vanbegin, M., Van Dooren, P., and Verhaegen, M.H.G. +C Algorithm 675: FORTRAN Subroutines for Computing the Square +C Root Covariance Filter and Square Root Information Filter in +C Dense or Hessenberg Forms. +C ACM Trans. Math. Software, 15, pp. 243-256, 1989. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 3 2 2 3 +C (1/6)N + N x (3/2 x M + P) + 2 x N x M + 2/3 x M +C +C operations and is backward stable (see [3]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01HD by M. Vanbegin, +C P. Van Dooren, and M.H.G. Verhaegen. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003, February 14, 2004. +C +C KEYWORDS +C +C Controller Hessenberg form, Kalman filtering, optimal filtering, +C orthogonal transformation, recursive estimation, square-root +C filtering, square-root information filtering. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBX, MULTRC + INTEGER INFO, LDAINB, LDAINV, LDC, LDQINV, LDRINV, + $ LDSINV, LDWORK, M, N, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION AINV(LDAINV,*), AINVB(LDAINB,*), C(LDC,*), + $ DWORK(*), E(*), QINV(LDQINV,*), RINV(LDRINV,*), + $ RINVY(*), SINV(LDSINV,*), X(*), Z(*) +C .. Local Scalars .. + LOGICAL LJOBX, LMULTR + INTEGER I, I12, I13, I23, I32, I33, II, IJ, ITAU, JWORK, + $ LDW, M1, MP1, N1, NM, NP, WRKOPT + DOUBLE PRECISION RCOND +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLACPY, DTRMM, DTRMV, MB02OD, + $ MB04ID, MB04KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + NP = N + P + NM = N + M + N1 = MAX( 1, N ) + M1 = MAX( 1, M ) + MP1 = M + 1 + INFO = 0 + LJOBX = LSAME( JOBX, 'X' ) + LMULTR = LSAME( MULTRC, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LMULTR .AND. .NOT.LSAME( MULTRC, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDSINV.LT.N1 ) THEN + INFO = -7 + ELSE IF( LDAINV.LT.N1 ) THEN + INFO = -9 + ELSE IF( LDAINB.LT.N1 ) THEN + INFO = -11 + ELSE IF( LDRINV.LT.1 .OR. ( .NOT.LMULTR .AND. LDRINV.LT.P ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDQINV.LT.M1 ) THEN + INFO = -17 + ELSE IF( ( LJOBX .AND. LDWORK.LT.MAX( 2, N*(NM + M) + 3*M, + $ NP*(N + 1) + N + + $ MAX( N - 1, MP1 ), 3*N ) ) + $ .OR. + $ ( .NOT.LJOBX .AND. LDWORK.LT.MAX( 1, N*(NM + M) + 3*M, + $ NP*(N + 1) + N + + $ MAX( N - 1, MP1 ) ) ) ) THEN + INFO = -25 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, P ).EQ.0 ) THEN + IF ( LJOBX ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + ELSE + DWORK(1) = ONE + END IF + RETURN + END IF +C +C Construction of the needed part of the pre-array in DWORK. +C To save workspace, only the blocks (1,3), (3,1)-(3,3), (2,2), and +C (2,3) will be constructed when needed as shown below. +C +C Storing SINV x AINVB and SINV x AINV in the (1,1) and (1,2) +C blocks of DWORK, respectively. The upper trapezoidal structure of +C [ AINVB AINV ] is fully exploited. Specifically, if M <= N, the +C following partition is used: +C +C [ S1 S2 ] [ B1 A1 A3 ] +C [ 0 S3 ] [ 0 A2 A4 ], +C +C where B1, A3, and S1 are M-by-M matrices, A1 and S2 are +C M-by-(N-M), A2 and S3 are (N-M)-by-(N-M), A4 is (N-M)-by-M, and +C B1, S1, A2, and S3 are upper triangular. The right hand side +C matrix above is stored in the workspace. If M > N, the partition +C is [ SINV ] [ B1 B2 A ], where B1 is N-by-N, B2 is N-by-(M-N), +C and B1 and SINV are upper triangular. +C The variables called Ixy define the starting positions where the +C (x,y) blocks of the pre-array are initially stored in DWORK. +C Workspace: need N*(M+N). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + LDW = N1 + I32 = N*M + 1 +C + CALL DLACPY( 'Upper', N, M, AINVB, LDAINB, DWORK, LDW ) + CALL DLACPY( 'Full', MIN( M, N ), N, AINV, LDAINV, DWORK(I32), + $ LDW ) + IF ( N.GT.M ) + $ CALL DLACPY( 'Upper', N-M, N, AINV(MP1,1), LDAINV, + $ DWORK(I32+M), LDW ) +C +C [ B1 A1 ] +C Compute SINV x [ 0 A2 ] or SINV x B1 as a product of upper +C triangular matrices. +C Workspace: need N*(M+N+1). +C + II = 1 + I13 = N*NM + 1 + WRKOPT = MAX( 1, N*NM + N ) +C + DO 10 I = 1, N + CALL DCOPY( I, DWORK(II), 1, DWORK(I13), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, SINV, + $ LDSINV, DWORK(I13), 1 ) + CALL DCOPY( I, DWORK(I13), 1, DWORK(II), 1 ) + II = II + N + 10 CONTINUE +C +C [ A3 ] +C Compute SINV x [ A4 ] or SINV x [ B2 A ]. +C + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, M, + $ ONE, SINV, LDSINV, DWORK(II), LDW ) +C +C Storing the process noise mean value in (1,3) block of DWORK. +C Workspace: need N*(M+N) + M. +C + CALL DCOPY( M, Z, 1, DWORK(I13), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', M, QINV, LDQINV, + $ DWORK(I13), 1 ) +C +C Computing SINV x X in X. +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, SINV, LDSINV, + $ X, 1 ) +C +C Triangularization (2 steps). +C +C Step 1: annihilate the matrix SINV x AINVB. +C Workspace: need N*(N+2*M) + 3*M. +C + I12 = I13 + M + ITAU = I12 + M*N + JWORK = ITAU + M +C + CALL MB04KD( 'Upper', M, N, N, QINV, LDQINV, DWORK, LDW, + $ DWORK(I32), LDW, DWORK(I12), M1, DWORK(ITAU), + $ DWORK(JWORK) ) + WRKOPT = MAX( WRKOPT, N*( NM + M ) + 3*M ) +C + IF ( N.EQ.0 ) THEN + CALL DCOPY( P, RINVY, 1, E, 1 ) + IF ( LJOBX ) + $ DWORK(2) = ONE + DWORK(1) = WRKOPT + RETURN + END IF +C +C Apply the transformations to the last column of the pre-array. +C (Only the updated (3,3) block is now needed.) +C + IJ = 1 +C + DO 20 I = 1, M + CALL DAXPY( MIN( I, N ), -DWORK(ITAU+I-1)*( DWORK(I13+I-1) + + $ DDOT( MIN( I, N ), DWORK(IJ), 1, X, 1 ) ), + $ DWORK(IJ), 1, X, 1 ) + IJ = IJ + N + 20 CONTINUE +C +C Now, the workspace for SINV x AINVB, as well as for the updated +C (1,2) block of the pre-array, are no longer needed. +C Move the computed (3,2) and (3,3) blocks of the pre-array in the +C (1,1) and (1,2) block positions of DWORK, to save space for the +C following computations. +C Then, adjust the implicitly defined leading dimension of DWORK, +C to make space for storing the (2,2) and (2,3) blocks of the +C pre-array. +C Workspace: need (P+N)*(N+1). +C + CALL DLACPY( 'Full', MIN( M, N ), N, DWORK(I32), LDW, DWORK, LDW ) + IF ( N.GT.M ) + $ CALL DLACPY( 'Upper', N-M, N, DWORK(I32+M), LDW, DWORK(MP1), + $ LDW ) + LDW = MAX( 1, NP ) +C + DO 40 I = N, 1, -1 + DO 30 IJ = MIN( N, I+M ), 1, -1 + DWORK(NP*(I-1)+P+IJ) = DWORK(N*(I-1)+IJ) + 30 CONTINUE + 40 CONTINUE +C +C Copy of RINV x C in the (1,1) block of DWORK. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDW ) + IF ( .NOT.LMULTR ) + $ CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', P, N, + $ ONE, RINV, LDRINV, DWORK, LDW ) +C +C Copy the inclusion measurement in the (1,2) block and the updated +C X in the (2,2) block of DWORK. +C + I23 = NP*N + 1 + I33 = I23 + P + CALL DCOPY( P, RINVY, 1, DWORK(I23), 1 ) + CALL DCOPY( N, X, 1, DWORK(I33), 1 ) + WRKOPT = MAX( WRKOPT, NP*( N + 1 ) ) +C +C Step 2: QR factorization of the first block column of the matrix +C +C [ RINV x C RINV x Y ], +C [ SINV x AINV SINV x X ] +C +C where the second block row was modified at Step 1. +C Workspace: need (P+N)*(N+1) + N + MAX(N-1,M+1); +C prefer (P+N)*(N+1) + N + (M+1)*NB, where NB is the +C optimal block size for DGEQRF called in MB04ID. +C + ITAU = I23 + NP + JWORK = ITAU + N +C + CALL MB04ID( NP, N, MAX( N-MP1, 0 ), 1, DWORK, LDW, DWORK(I23), + $ LDW, DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Output SINV, X, and E and set the optimal workspace dimension +C (and the reciprocal of the condition number estimate). +C + CALL DLACPY( 'Upper', N, N, DWORK, LDW, SINV, LDSINV ) + CALL DCOPY( N, DWORK(I23), 1, X, 1 ) + IF( P.GT.0 ) + $ CALL DCOPY( P, DWORK(I23+N), 1, E, 1 ) +C + IF ( LJOBX ) THEN +C +C Compute X. +C Workspace: need 3*N. +C + CALL MB02OD( 'Left', 'Upper', 'No transpose', 'Non-unit', + $ '1-norm', N, 1, ONE, SINV, LDSINV, X, N, RCOND, + $ TOL, IWORK, DWORK, INFO ) + IF ( INFO.EQ.0 ) THEN + WRKOPT = MAX( WRKOPT, 3*N ) + DWORK(2) = RCOND + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of FB01TD*** + END diff --git a/mex/sources/libslicot/FB01VD.f b/mex/sources/libslicot/FB01VD.f new file mode 100644 index 000000000..eabf21748 --- /dev/null +++ b/mex/sources/libslicot/FB01VD.f @@ -0,0 +1,391 @@ + SUBROUTINE FB01VD( N, M, L, P, LDP, A, LDA, B, LDB, C, LDC, Q, + $ LDQ, R, LDR, K, LDK, TOL, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute one recursion of the conventional Kalman filter +C equations. This is one update of the Riccati difference equation +C and the Kalman filter gain. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C matrices P and A . N >= 0. +C i|i-1 i +C +C M (input) INTEGER +C The actual input dimension, i.e., the order of the matrix +C Q . M >= 0. +C i +C +C L (input) INTEGER +C The actual output dimension, i.e., the order of the matrix +C R . L >= 0. +C i +C +C P (input/output) DOUBLE PRECISION array, dimension (LDP,N) +C On entry, the leading N-by-N part of this array must +C contain P , the state covariance matrix at instant +C i|i-1 +C (i-1). The upper triangular part only is needed. +C On exit, if INFO = 0, the leading N-by-N part of this +C array contains P , the state covariance matrix at +C i+1|i +C instant i. The strictly lower triangular part is not set. +C Otherwise, the leading N-by-N part of this array contains +C P , its input value. +C i|i-1 +C +C LDP INTEGER +C The leading dimension of array P. LDP >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain A , +C i +C the state transition matrix of the discrete system at +C instant i. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain B , +C i +C the input weight matrix of the discrete system at +C instant i. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array must contain C , +C i +C the output weight matrix of the discrete system at +C instant i. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,L). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,M) +C The leading M-by-M part of this array must contain Q , +C i +C the input (process) noise covariance matrix at instant i. +C The diagonal elements of this array are modified by the +C routine, but are restored on exit. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,M). +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) +C On entry, the leading L-by-L part of this array must +C contain R , the output (measurement) noise covariance +C i +C matrix at instant i. +C On exit, if INFO = 0, or INFO = L+1, the leading L-by-L +C 1/2 +C upper triangular part of this array contains (RINOV ) , +C i +C the square root (left Cholesky factor) of the covariance +C matrix of the innovations at instant i. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,L). +C +C K (output) DOUBLE PRECISION array, dimension (LDK,L) +C If INFO = 0, the leading N-by-L part of this array +C contains K , the Kalman filter gain matrix at instant i. +C i +C If INFO > 0, the leading N-by-L part of this array +C contains the matrix product P C'. +C i|i-1 i +C +C LDK INTEGER +C The leading dimension of array K. LDK >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the matrix RINOV . If the user sets TOL > 0, then the +C i +C given value of TOL is used as a lower bound for the +C reciprocal condition number of that matrix; a matrix whose +C estimated condition number is less than 1/TOL is +C considered to be nonsingular. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = L*L*EPS, is used instead, where EPS is the +C machine precision (see LAPACK Library routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (L) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, or INFO = L+1, DWORK(1) returns an +C estimate of the reciprocal of the condition number (in the +C 1-norm) of the matrix RINOV . +C i +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,L*N+3*L,N*N,N*M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value; +C = k: if INFO = k, 1 <= k <= L, the leading minor of order +C k of the matrix RINOV is not positive-definite, and +C i +C its Cholesky factorization could not be completed; +C = L+1: the matrix RINOV is singular, i.e., the condition +C i +C number estimate of RINOV (in the 1-norm) exceeds +C i +C 1/TOL. +C +C METHOD +C +C The conventional Kalman filter gain used at the i-th recursion +C step is of the form +C +C -1 +C K = P C' RINOV , +C i i|i-1 i i +C +C where RINOV = C P C' + R , and the state covariance matrix +C i i i|i-1 i i +C +C P is updated by the discrete-time difference Riccati equation +C i|i-1 +C +C P = A (P - K C P ) A' + B Q B'. +C i+1|i i i|i-1 i i i|i-1 i i i i +C +C Using these two updates, the combined time and measurement update +C of the state X is given by +C i|i-1 +C +C X = A X + A K (Y - C X ), +C i+1|i i i|i-1 i i i i i|i-1 +C +C where Y is the new observation at step i. +C i +C +C REFERENCES +C +C [1] Anderson, B.D.O. and Moore, J.B. +C Optimal Filtering, +C Prentice Hall, Englewood Cliffs, New Jersey, 1979. +C +C [2] Verhaegen, M.H.G. and Van Dooren, P. +C Numerical Aspects of Different Kalman Filter Implementations. +C IEEE Trans. Auto. Contr., AC-31, pp. 907-917, 1986. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 3 2 +C 3/2 x N + N x (3 x L + M/2) +C +C operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Supersedes Release 2.0 routine FB01JD by M.H.G. Verhaegen, +C M. Vanbegin, and P. Van Dooren. +C +C REVISIONS +C +C February 20, 1998, November 20, 2003, April 20, 2004. +C +C KEYWORDS +C +C Kalman filtering, optimal filtering, recursive estimation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDB, LDC, LDK, LDP, LDQ, LDR, + $ LDWORK, M, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ K(LDK,*), P(LDP,*), Q(LDQ,*), R(LDR,*) +C .. Local Scalars .. + INTEGER J, JWORK, LDW, N1 + DOUBLE PRECISION RCOND, RNORM, TOLDEF +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLACPY, DLASET, DPOCON, + $ DPOTRF, DSCAL, DTRMM, DTRSM, MB01RD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + N1 = MAX( 1, N ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 ) THEN + INFO = -3 + ELSE IF( LDP.LT.N1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -7 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDQ.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDR.LT.MAX( 1, L ) ) THEN + INFO = -15 + ELSE IF( LDK.LT.N1 ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.MAX( 1, L*N + 3*L, N*N, N*M ) ) THEN + INFO = -21 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FB01VD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, L ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Efficiently compute RINOV = CPC' + R in R and put CP in DWORK and +C PC' in K. (The content of DWORK on exit from MB01RD is used.) +C Workspace: need L*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code.) +C + CALL MB01RD( 'Upper', 'No transpose', L, N, ONE, ONE, R, LDR, C, + $ LDC, P, LDP, DWORK, LDWORK, INFO ) + LDW = MAX( 1, L ) +C + DO 10 J = 1, L + CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) + 10 CONTINUE +C + CALL DLACPY( 'Full', L, N, C, LDC, DWORK, LDW ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', L, N, ONE, + $ P, LDP, DWORK, LDW ) + CALL DSCAL( N, TWO, P, LDP+1 ) +C + DO 20 J = 1, L + CALL DAXPY( N, ONE, K(1,J), 1, DWORK(J), LDW ) + CALL DCOPY( N, DWORK(J), LDW, K(1,J), 1 ) + 20 CONTINUE +C +C Calculate the Cholesky decomposition U'U of the innovation +C covariance matrix RINOV, and its reciprocal condition number. +C Workspace: need L*N + 3*L. +C + JWORK = L*N + 1 + RNORM = DLANSY( '1-norm', 'Upper', L, R, LDR, DWORK(JWORK) ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DBLE( L*L )*DLAMCH( 'Epsilon' ) + CALL DPOTRF( 'Upper', L, R, LDR, INFO ) + IF ( INFO.NE.0 ) + $ RETURN +C + CALL DPOCON( 'Upper', L, R, LDR, RNORM, RCOND, DWORK(JWORK), + $ IWORK, INFO ) +C + IF ( RCOND.LT.TOLDEF ) THEN +C +C Error return: RINOV is numerically singular. +C + INFO = L+1 + DWORK(1) = RCOND + RETURN + END IF +C + IF ( L.GT.1 ) + $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(2,1),LDR ) +C -1 +C Calculate the Kalman filter gain matrix K = PC'RINOV . +C Workspace: need L*N. +C + CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, + $ ONE, R, LDR, K, LDK ) + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', N, L, + $ ONE, R, LDR, K, LDK ) +C +C First part of the Riccati equation update: compute A(P-KCP)A'. +C The upper triangular part of the symmetric matrix P-KCP is formed. +C Workspace: need max(L*N,N*N). +C + JWORK = 1 +C + DO 30 J = 1, N + CALL DGEMV( 'No transpose', J, L, -ONE, K, LDK, DWORK(JWORK), + $ 1, ONE, P(1,J), 1 ) + JWORK = JWORK + L + 30 CONTINUE +C + CALL MB01RD( 'Upper', 'No transpose', N, N, ZERO, ONE, P, LDP, A, + $ LDA, P, LDP, DWORK, LDWORK, INFO ) +C +C Second part of the Riccati equation update: add BQB'. +C Workspace: need N*M. +C + CALL MB01RD( 'Upper', 'No transpose', N, M, ONE, ONE, P, LDP, B, + $ LDB, Q, LDQ, DWORK, LDWORK, INFO ) + CALL DSCAL( M, TWO, Q, LDQ+1 ) +C +C Set the reciprocal of the condition number estimate. +C + DWORK(1) = RCOND +C + RETURN +C *** Last line of FB01VD *** + END diff --git a/mex/sources/libslicot/FD01AD.f b/mex/sources/libslicot/FD01AD.f new file mode 100644 index 000000000..79fef1b65 --- /dev/null +++ b/mex/sources/libslicot/FD01AD.f @@ -0,0 +1,367 @@ + SUBROUTINE FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK, + $ CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the least-squares filtering problem recursively in time. +C Each subroutine call implements one time update of the solution. +C The algorithm uses a fast QR-decomposition based approach. +C +C ARGUMENTS +C +C Mode Parameters +C +C JP CHARACTER*1 +C Indicates whether the user wishes to apply both prediction +C and filtering parts, as follows: +C = 'B': Both prediction and filtering parts are to be +C applied; +C = 'P': Only the prediction section is to be applied. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The length of the impulse response of the equivalent +C transversal filter model. L >= 1. +C +C LAMBDA (input) DOUBLE PRECISION +C Square root of the forgetting factor. +C For tracking capabilities and exponentially stable error +C propagation, LAMBDA < 1.0 (strict inequality) should +C be used. 0.0 < LAMBDA <= 1.0. +C +C XIN (input) DOUBLE PRECISION +C The input sample at instant n. +C (The situation just before and just after the call of +C the routine are denoted by instant (n-1) and instant n, +C respectively.) +C +C YIN (input) DOUBLE PRECISION +C If JP = 'B', then YIN must contain the reference sample +C at instant n. +C Otherwise, YIN is not referenced. +C +C EFOR (input/output) DOUBLE PRECISION +C On entry, this parameter must contain the square root of +C exponentially weighted forward prediction error energy +C at instant (n-1). EFOR >= 0.0. +C On exit, this parameter contains the square root of the +C exponentially weighted forward prediction error energy +C at instant n. +C +C XF (input/output) DOUBLE PRECISION array, dimension (L) +C On entry, this array must contain the transformed forward +C prediction variables at instant (n-1). +C On exit, this array contains the transformed forward +C prediction variables at instant n. +C +C EPSBCK (input/output) DOUBLE PRECISION array, dimension (L+1) +C On entry, the leading L elements of this array must +C contain the normalized a posteriori backward prediction +C error residuals of orders zero through L-1, respectively, +C at instant (n-1), and EPSBCK(L+1) must contain the +C square-root of the so-called "conversion factor" at +C instant (n-1). +C On exit, this array contains the normalized a posteriori +C backward prediction error residuals, plus the square root +C of the conversion factor at instant n. +C +C CTETA (input/output) DOUBLE PRECISION array, dimension (L) +C On entry, this array must contain the cosines of the +C rotation angles used in time updates, at instant (n-1). +C On exit, this array contains the cosines of the rotation +C angles at instant n. +C +C STETA (input/output) DOUBLE PRECISION array, dimension (L) +C On entry, this array must contain the sines of the +C rotation angles used in time updates, at instant (n-1). +C On exit, this array contains the sines of the rotation +C angles at instant n. +C +C YQ (input/output) DOUBLE PRECISION array, dimension (L) +C On entry, if JP = 'B', then this array must contain the +C orthogonally transformed reference vector at instant +C (n-1). These elements are also the tap multipliers of an +C equivalent normalized lattice least-squares filter. +C Otherwise, YQ is not referenced and can be supplied as +C a dummy array (i.e., declare this array to be YQ(1) in +C the calling program). +C On exit, if JP = 'B', then this array contains the +C orthogonally transformed reference vector at instant n. +C +C EPOS (output) DOUBLE PRECISION +C The a posteriori forward prediction error residual. +C +C EOUT (output) DOUBLE PRECISION +C If JP = 'B', then EOUT contains the a posteriori output +C error residual from the least-squares filter at instant n. +C +C SALPH (output) DOUBLE PRECISION array, dimension (L) +C The element SALPH(i), i=1,...,L, contains the opposite of +C the i-(th) reflection coefficient for the least-squares +C normalized lattice predictor (whose value is -SALPH(i)). +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: an element to be annihilated by a rotation is less +C than the machine precision (see LAPACK Library +C routine DLAMCH). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The output error EOUT at instant n, denoted by EOUT(n), is the +C reference sample minus a linear combination of L successive input +C samples: +C +C L-1 +C EOUT(n) = YIN(n) - SUM h_i * XIN(n-i), +C i=0 +C +C where YIN(n) and XIN(n) are the scalar samples at instant n. +C A least-squares filter uses those h_0,...,h_{L-1} which minimize +C an exponentially weighted sum of successive output errors squared: +C +C n +C SUM [LAMBDA**(2(n-k)) * EOUT(k)**2]. +C k=1 +C +C Each subroutine call performs a time update of the least-squares +C filter using a fast least-squares algorithm derived from a +C QR decomposition, as described in references [1] and [2] (the +C notation from [2] is followed in the naming of the arrays). +C The algorithm does not compute the parameters h_0,...,h_{L-1} from +C the above formula, but instead furnishes the parameters of an +C equivalent normalized least-squares lattice filter, which are +C available from the arrays SALPH (reflection coefficients) and YQ +C (tap multipliers), as well as the exponentially weighted input +C signal energy +C +C n L +C SUM [LAMBDA**(2(n-k)) * XIN(k)**2] = EFOR**2 + SUM XF(i)**2. +C k=1 i=1 +C +C For more details on reflection coefficients and tap multipliers, +C references [2] and [4] are recommended. +C +C REFERENCES +C +C [1] Proudler, I. K., McWhirter, J. G., and Shepherd, T. J. +C Fast QRD based algorithms for least-squares linear +C prediction. +C Proceedings IMA Conf. Mathematics in Signal Processing +C Warwick, UK, December 1988. +C +C [2] Regalia, P. A., and Bellanger, M. G. +C On the duality between QR methods and lattice methods in +C least-squares adaptive filtering. +C IEEE Trans. Signal Processing, SP-39, pp. 879-891, +C April 1991. +C +C [3] Regalia, P. A. +C Numerical stability properties of a QR-based fast +C least-squares algorithm. +C IEEE Trans. Signal Processing, SP-41, June 1993. +C +C [4] Lev-Ari, H., Kailath, T., and Cioffi, J. +C Least-squares adaptive lattice and transversal filters: +C A unified geometric theory. +C IEEE Trans. Information Theory, IT-30, pp. 222-236, +C March 1984. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(L) operations for each subroutine call. +C It is backward consistent for all input sequences XIN, and +C backward stable for persistently exciting input sequences, +C assuming LAMBDA < 1.0 (see [3]). +C If the condition of the signal is very poor (IWARN = 1), then the +C results are not guaranteed to be reliable. +C +C FURTHER COMMENTS +C +C 1. For tracking capabilities and exponentially stable error +C propagation, LAMBDA < 1.0 should be used. LAMBDA is typically +C chosen slightly less than 1.0 so that "past" data are +C exponentially forgotten. +C 2. Prior to the first subroutine call, the variables must be +C initialized. The following initial values are recommended: +C +C XF(i) = 0.0, i=1,...,L +C EPSBCK(i) = 0.0 i=1,...,L +C EPSBCK(L+1) = 1.0 +C CTETA(i) = 1.0 i=1,...,L +C STETA(i) = 0.0 i=1,...,L +C YQ(i) = 0.0 i=1,...,L +C +C EFOR = 0.0 (exact start) +C EFOR = "small positive constant" (soft start). +C +C Soft starts are numerically more reliable, but result in a +C biased least-squares solution during the first few iterations. +C This bias decays exponentially fast provided LAMBDA < 1.0. +C If sigma is the standard deviation of the input sequence +C XIN, then initializing EFOR = sigma*1.0E-02 usually works +C well. +C +C CONTRIBUTOR +C +C P. A. Regalia (October 1994). +C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Kalman filtering, least-squares estimator, optimal filtering, +C orthogonal transformation, recursive estimation, QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JP + INTEGER INFO, IWARN, L + DOUBLE PRECISION EFOR, EOUT, EPOS, LAMBDA, XIN, YIN +C .. Array Arguments .. + DOUBLE PRECISION CTETA(*), EPSBCK(*), SALPH(*), STETA(*), XF(*), + $ YQ(*) +C .. Local Scalars .. + LOGICAL BOTH + INTEGER I + DOUBLE PRECISION CTEMP, EPS, FNODE, NORM, TEMP, XFI, YQI +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DLARTG, XERBLA +C .. Intrinsic Functions + INTRINSIC ABS, SQRT +C .. Executable statements .. +C +C Test the input scalar arguments. +C + BOTH = LSAME( JP, 'B' ) + IWARN = 0 + INFO = 0 +C + IF( .NOT.BOTH .AND. .NOT.LSAME( JP, 'P' ) ) THEN + INFO = -1 + ELSE IF( L.LT.1 ) THEN + INFO = -2 + ELSE IF( ( LAMBDA.LE.ZERO ) .OR. ( LAMBDA.GT.ONE ) ) THEN + INFO = -3 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'FD01AD', -INFO ) + RETURN + END IF +C +C Computation of the machine precision EPS. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Forward prediction rotations. +C + FNODE = XIN +C + DO 10 I = 1, L + XFI = XF(I) * LAMBDA + XF(I) = STETA(I) * FNODE + CTETA(I) * XFI + FNODE = CTETA(I) * FNODE - STETA(I) * XFI + 10 CONTINUE +C + EPOS = FNODE * EPSBCK(L+1) +C +C Update the square root of the prediction energy. +C + EFOR = EFOR * LAMBDA + TEMP = DLAPY2( FNODE, EFOR ) + IF ( TEMP.LT.EPS ) THEN + FNODE = ZERO + IWARN = 1 + ELSE + FNODE = FNODE * EPSBCK(L+1)/TEMP + END IF + EFOR = TEMP +C +C Calculate the reflection coefficients and the backward prediction +C errors. +C + DO 20 I = L, 1, -1 + IF ( ABS( XF(I) ).LT.EPS ) + $ IWARN = 1 + CALL DLARTG( TEMP, XF(I), CTEMP, SALPH(I), NORM ) + EPSBCK(I+1) = CTEMP * EPSBCK(I) - SALPH(I) * FNODE + FNODE = CTEMP * FNODE + SALPH(I) * EPSBCK(I) + TEMP = NORM + 20 CONTINUE +C + EPSBCK(1) = FNODE +C +C Update to new rotation angles. +C + NORM = DNRM2( L, EPSBCK, 1 ) + TEMP = SQRT( ( ONE + NORM )*( ONE - NORM ) ) + EPSBCK(L+1) = TEMP +C + DO 30 I = L, 1, -1 + IF ( ABS( EPSBCK(I) ).LT.EPS ) + $ IWARN = 1 + CALL DLARTG( TEMP, EPSBCK(I), CTETA(I), STETA(I), NORM ) + TEMP = NORM + 30 CONTINUE +C +C Joint process section. +C + IF ( BOTH) THEN + FNODE = YIN +C + DO 40 I = 1, L + YQI = YQ(I) * LAMBDA + YQ(I) = STETA(I) * FNODE + CTETA(I) * YQI + FNODE = CTETA(I) * FNODE - STETA(I) * YQI + 40 CONTINUE +C + EOUT = FNODE * EPSBCK(L+1) + END IF +C + RETURN +C *** Last line of FD01AD *** + END diff --git a/mex/sources/libslicot/IB01AD.f b/mex/sources/libslicot/IB01AD.f new file mode 100644 index 000000000..301cdd529 --- /dev/null +++ b/mex/sources/libslicot/IB01AD.f @@ -0,0 +1,686 @@ + SUBROUTINE IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, + $ L, NSMP, U, LDU, Y, LDY, N, R, LDR, SV, RCOND, + $ TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To preprocess the input-output data for estimating the matrices +C of a linear time-invariant dynamical system and to find an +C estimate of the system order. The input-output data can, +C optionally, be processed sequentially. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C ALG CHARACTER*1 +C Specifies the algorithm for computing the triangular +C factor R, as follows: +C = 'C': Cholesky algorithm applied to the correlation +C matrix of the input-output data; +C = 'F': Fast QR algorithm; +C = 'Q': QR algorithm applied to the concatenated block +C Hankel matrices. +C +C JOBD CHARACTER*1 +C Specifies whether or not the matrices B and D should later +C be computed using the MOESP approach, as follows: +C = 'M': the matrices B and D should later be computed +C using the MOESP approach; +C = 'N': the matrices B and D should not be computed using +C the MOESP approach. +C This parameter is not relevant for METH = 'N'. +C +C BATCH CHARACTER*1 +C Specifies whether or not sequential data processing is to +C be used, and, for sequential processing, whether or not +C the current data block is the first block, an intermediate +C block, or the last block, as follows: +C = 'F': the first block in sequential data processing; +C = 'I': an intermediate block in sequential data +C processing; +C = 'L': the last block in sequential data processing; +C = 'O': one block only (non-sequential data processing). +C NOTE that when 100 cycles of sequential data processing +C are completed for BATCH = 'I', a warning is +C issued, to prevent for an infinite loop. +C +C CONCT CHARACTER*1 +C Specifies whether or not the successive data blocks in +C sequential data processing belong to a single experiment, +C as follows: +C = 'C': the current data block is a continuation of the +C previous data block and/or it will be continued +C by the next data block; +C = 'N': there is no connection between the current data +C block and the previous and/or the next ones. +C This parameter is not used if BATCH = 'O'. +C +C CTRL CHARACTER*1 +C Specifies whether or not the user's confirmation of the +C system order estimate is desired, as follows: +C = 'C': user's confirmation; +C = 'N': no confirmation. +C If CTRL = 'C', a reverse communication routine, IB01OY, +C is indirectly called (by SLICOT Library routine IB01OD), +C and, after inspecting the singular values and system order +C estimate, n, the user may accept n or set a new value. +C IB01OY is not called if CTRL = 'N'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C block Hankel matrices to be processed. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, +C the estimated dimension of state vector.) +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C When M = 0, no system inputs are processed. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). (When sequential data processing is used, +C NSMP is the number of samples of the current data +C block.) +C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential +C processing; +C NSMP >= 2*NOBR, for sequential processing. +C The total number of samples when calling the routine with +C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. +C The NSMP argument may vary from a cycle to another in +C sequential data processing, but NOBR, M, and L should +C be kept constant. For efficiency, it is advisable to use +C NSMP as large as possible. +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NSMP-by-M part of this array must contain the +C t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= NSMP, if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= NSMP. +C +C N (output) INTEGER +C The estimated order of the system. +C If CTRL = 'C', the estimated order has been reset to a +C value specified by the user. +C +C R (output or input/output) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this +C array contains the current upper triangular part of the +C correlation matrix in sequential data processing. +C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not +C referenced. +C On exit, if INFO = 0, ALG = 'Q', and BATCH = 'F' or 'I', +C the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular +C part of this array contains the current upper triangular +C factor R from the QR factorization of the concatenated +C block Hankel matrices. Denote R_ij, i,j = 1:4, the +C ij submatrix of R, partitioned by M*NOBR, M*NOBR, +C L*NOBR, and L*NOBR rows and columns. +C On exit, if INFO = 0 and BATCH = 'L' or 'O', the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of +C this array contains the matrix S, the processed upper +C triangular factor R from the QR factorization of the +C concatenated block Hankel matrices, as required by other +C subroutines. Specifically, let S_ij, i,j = 1:4, be the +C ij submatrix of S, partitioned by M*NOBR, L*NOBR, +C M*NOBR, and L*NOBR rows and columns. The submatrix +C S_22 contains the matrix of left singular vectors needed +C subsequently. Useful information is stored in S_11 and +C in the block-column S_14 : S_44. For METH = 'M' and +C JOBD = 'M', the upper triangular part of S_31 contains +C the upper triangular factor in the QR factorization of the +C matrix R_1c = [ R_12' R_22' R_11' ]', and S_12 +C contains the corresponding leading part of the transformed +C matrix R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', +C the subarray S_41 : S_43 contains the transpose of the +C matrix contained in S_14 : S_34. +C The details of the contents of R need not be known if this +C routine is followed by SLICOT Library routine IB01BD. +C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or +C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper +C triangular part of this array must contain the upper +C triangular matrix R computed at the previous call of this +C routine in sequential data processing. The array R need +C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), +C for METH = 'M' and JOBD = 'M'; +C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or +C for METH = 'N'. +C +C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) +C The singular values used to estimate the system order. +C +C Tolerances +C +C RCOND DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets RCOND > 0, the given value +C of RCOND is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/RCOND is considered to +C be of full rank. If the user sets RCOND <= 0, then an +C implicitly computed, default tolerance, defined by +C RCONDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not used for METH = 'M'. +C +C TOL DOUBLE PRECISION +C Absolute tolerance used for determining an estimate of +C the system order. If TOL >= 0, the estimate is +C indicated by the index of the last singular value greater +C than or equal to TOL. (Singular values less than TOL +C are considered as zero.) When TOL = 0, an internally +C computed default value, TOL = NOBR*EPS*SV(1), is used, +C where SV(1) is the maximal singular value, and EPS is +C the relative machine precision (see LAPACK Library routine +C DLAMCH). When TOL < 0, the estimate is indicated by the +C index of the singular value that has the largest +C logarithmic gap to its successor. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= (M+L)*NOBR, if METH = 'N'; +C LIWORK >= M+L, if METH = 'M' and ALG = 'F'; +C LIWORK >= 0, if METH = 'M' and ALG = 'C' or 'Q'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and, for METH = 'N', and BATCH = 'L' or +C 'O', DWORK(2) and DWORK(3) contain the reciprocal +C condition numbers of the triangular factors of the +C matrices U_f and r_1 [6]. +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C Let +C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; +C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; +C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; +C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. +C The first (M+L)*k elements of DWORK should be preserved +C during successive calls of the routine with BATCH = 'F' +C or 'I', till the final call with BATCH = 'L'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH = 'F' or +C 'I' and CONCT = 'C'; +C LDWORK >= 1, if ALG = 'C', BATCH = 'F' or 'I' and +C CONCT = 'N'; +C LDWORK >= max((4*NOBR-2)*(M+L), 5*L*NOBR), if METH = 'M', +C ALG = 'C', BATCH = 'L' and CONCT = 'C'; +C LDWORK >= max((2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR), +C if METH = 'M', JOBD = 'M', ALG = 'C', +C BATCH = 'O', or +C (BATCH = 'L' and CONCT = 'N'); +C LDWORK >= 5*L*NOBR, if METH = 'M', JOBD = 'N', ALG = 'C', +C BATCH = 'O', or +C (BATCH = 'L' and CONCT = 'N'); +C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'C', and +C BATCH = 'L' or 'O'; +C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', +C BATCH <> 'O' and CONCT = 'C'; +C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', +C BATCH = 'F', 'I' and CONCT = 'N'; +C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', +C BATCH = 'L' and CONCT = 'N', or +C BATCH = 'O'; +C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F', and +C LDR >= NS = NSMP - 2*NOBR + 1; +C LDWORK >= max(4*(M+L)*NOBR, 5*L*NOBR), if METH = 'M', +C ALG = 'Q', BATCH = 'O', and LDR >= NS; +C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'Q', +C BATCH = 'O', and LDR >= NS; +C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', (BATCH = 'F' or 'O', +C and LDR < NS), or (BATCH = 'I' or +C 'L' and CONCT = 'N'); +C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' +C or 'L' and CONCT = 'C'. +C The workspace used for ALG = 'Q' is +C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, +C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended +C value LDRWRK = NS, assuming a large enough cache size. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the number of 100 cycles in sequential data +C processing has been exhausted without signaling +C that the last block of data was get; the cycle +C counter was reinitialized; +C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), +C but it failed, and the QR algorithm was then used +C (non-sequential data processing); +C = 3: all singular values were exactly zero, hence N = 0 +C (both input and output were identically zero); +C = 4: the least squares problems with coefficient matrix +C U_f, used for computing the weighted oblique +C projection (for METH = 'N'), have a rank-deficient +C coefficient matrix; +C = 5: the least squares problem with coefficient matrix +C r_1 [6], used for computing the weighted oblique +C projection (for METH = 'N'), has a rank-deficient +C coefficient matrix. +C NOTE: the values 4 and 5 of IWARN have no significance +C for the identification problem. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: a fast algorithm was requested (ALG = 'C', or 'F') +C in sequential data processing, but it failed; the +C routine can be repeatedly called again using the +C standard QR algorithm; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C The procedure consists in three main steps, the first step being +C performed by one of the three algorithms included. +C +C 1.a) For non-sequential data processing using QR algorithm, a +C t x 2(m+l)s matrix H is constructed, where +C +C H = [ Uf' Up' Y' ], for METH = 'M', +C s+1,2s,t 1,s,t 1,2s,t +C +C H = [ U' Y' ], for METH = 'N', +C 1,2s,t 1,2s,t +C +C and Up , Uf , U , and Y are block Hankel +C 1,s,t s+1,2s,t 1,2s,t 1,2s,t +C matrices defined in terms of the input and output data [3]. +C A QR factorization is used to compress the data. +C The fast QR algorithm uses a QR factorization which exploits +C the block-Hankel structure. Actually, the Cholesky factor of H'*H +C is computed. +C +C 1.b) For sequential data processing using QR algorithm, the QR +C decomposition is done sequentially, by updating the upper +C triangular factor R. This is also performed internally if the +C workspace is not large enough to accommodate an entire batch. +C +C 1.c) For non-sequential or sequential data processing using +C Cholesky algorithm, the correlation matrix of input-output data is +C computed (sequentially, if requested), taking advantage of the +C block Hankel structure [7]. Then, the Cholesky factor of the +C correlation matrix is found, if possible. +C +C 2) A singular value decomposition (SVD) of a certain matrix is +C then computed, which reveals the order n of the system as the +C number of "non-zero" singular values. For the MOESP approach, this +C matrix is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), +C where R is the upper triangular factor R constructed by SLICOT +C Library routine IB01MD. For the N4SID approach, a weighted +C oblique projection is computed from the upper triangular factor R +C and its SVD is then found. +C +C 3) The singular values are compared to the given, or default TOL, +C and the estimated order n is returned, possibly after user's +C confirmation. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Verhaegen M. +C Subspace Model Identification. Part 3: Analysis of the +C ordinary output-error state-space model identification +C algorithm. +C Int. J. Control, 58, pp. 555-586, 1993. +C +C [3] Verhaegen M. +C Identification of the deterministic part of MIMO state space +C models given in innovations form from input-output data. +C Automatica, Vol.30, No.1, pp.61-74, 1994. +C +C [4] Van Overschee, P., and De Moor, B. +C N4SID: Subspace Algorithms for the Identification of +C Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [5] Peternell, K., Scherrer, W. and Deistler, M. +C Statistical Analysis of Novel Subspace Identification Methods. +C Signal Processing, 52, pp. 161-177, 1996. +C +C [6] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C [7] Sima, V. +C Cholesky or QR Factorization for Data Compression in +C Subspace-based Identification ? +C Proceedings of the Second NICONET Workshop on ``Numerical +C Control Software: SLICOT, a Useful Tool in Industry'', +C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable (when QR algorithm is +C used), reliable and efficient. The fast Cholesky or QR algorithms +C are more efficient, but the accuracy could diminish by forming the +C correlation matrix. +C The most time-consuming computational step is step 1: +C 2 +C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. +C 2 3 +C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating +C point operations. +C 2 3 2 +C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating +C point operations. +C 3 +C Step 2 of the algorithm requires 0(((m+l)s) ) floating point +C operations. +C +C FURTHER COMMENTS +C +C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the +C calculations could be rather inefficient if only minimal workspace +C (see argument LDWORK) is provided. It is advisable to provide as +C much workspace as possible. Almost optimal efficiency can be +C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the +C cache size is large enough to accommodate R, U, Y, and DWORK. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. +C +C REVISIONS +C +C August 2000, March 2005. +C +C KEYWORDS +C +C Cholesky decomposition, Hankel matrix, identification methods, +C multivariable systems, QR decomposition, singular value +C decomposition. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + DOUBLE PRECISION RCOND, TOL + INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, N, + $ NOBR, NSMP + CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*), U(LDU, *), + $ Y(LDY, *) +C .. Local Scalars .. + INTEGER IWARNL, LMNOBR, LNOBR, MAXWRK, MINWRK, MNOBR, + $ NOBR21, NR, NS, NSMPSM + LOGICAL CHALG, CONNEC, CONTRL, FIRST, FQRALG, INTERM, + $ JOBDM, LAST, MOESP, N4SID, ONEBCH, QRALG +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL IB01MD, IB01ND, IB01OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Save Statement .. +C MAXWRK is used to store the optimal workspace. +C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. + SAVE MAXWRK, NSMPSM +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + FQRALG = LSAME( ALG, 'F' ) + QRALG = LSAME( ALG, 'Q' ) + CHALG = LSAME( ALG, 'C' ) + JOBDM = LSAME( JOBD, 'M' ) + ONEBCH = LSAME( BATCH, 'O' ) + FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH + INTERM = LSAME( BATCH, 'I' ) + LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH + CONTRL = LSAME( CTRL, 'C' ) +C + IF( .NOT.ONEBCH ) THEN + CONNEC = LSAME( CONCT, 'C' ) + ELSE + CONNEC = .FALSE. + END IF +C + MNOBR = M*NOBR + LNOBR = L*NOBR + LMNOBR = LNOBR + MNOBR + NR = LMNOBR + LMNOBR + NOBR21 = 2*NOBR - 1 + IWARN = 0 + INFO = 0 + IF( FIRST ) THEN + MAXWRK = 1 + NSMPSM = 0 + END IF + NSMPSM = NSMPSM + NSMP +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN + INFO = -2 + ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN + INFO = -4 + ELSE IF( .NOT. ONEBCH ) THEN + IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) + $ INFO = -5 + END IF + IF( INFO.EQ.0 ) THEN + IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN + INFO = -6 + ELSE IF( NOBR.LE.0 ) THEN + INFO = -7 + ELSE IF( M.LT.0 ) THEN + INFO = -8 + ELSE IF( L.LE.0 ) THEN + INFO = -9 + ELSE IF( NSMP.LT.2*NOBR .OR. + $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -12 + ELSE IF( LDY.LT.NSMP ) THEN + INFO = -14 + ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. + $ LDR.LT.3*MNOBR ) ) THEN + INFO = -17 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe +C the minimal amount of workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + NS = NSMP - NOBR21 + IF ( CHALG ) THEN + IF ( .NOT.LAST ) THEN + IF ( CONNEC ) THEN + MINWRK = 2*( NR - M - L ) + ELSE + MINWRK = 1 + END IF + ELSE IF ( MOESP ) THEN + IF ( CONNEC .AND. .NOT.ONEBCH ) THEN + MINWRK = MAX( 2*( NR - M - L ), 5*LNOBR ) + ELSE + MINWRK = 5*LNOBR + IF ( JOBDM ) + $ MINWRK = MAX( 2*MNOBR - NOBR, LMNOBR, MINWRK ) + END IF + ELSE + MINWRK = 5*LMNOBR + 1 + END IF + ELSE IF ( FQRALG ) THEN + IF ( .NOT.ONEBCH .AND. CONNEC ) THEN + MINWRK = NR*( M + L + 3 ) + ELSE IF ( FIRST .OR. INTERM ) THEN + MINWRK = NR*( M + L + 1 ) + ELSE + MINWRK = 2*NR*( M + L + 1 ) + NR + END IF + ELSE + MINWRK = 2*NR + IF ( ONEBCH .AND. LDR.GE.NS ) THEN + IF ( MOESP ) THEN + MINWRK = MAX( MINWRK, 5*LNOBR ) + ELSE + MINWRK = 5*LMNOBR + 1 + END IF + END IF + IF ( FIRST ) THEN + IF ( LDR.LT.NS ) THEN + MINWRK = MINWRK + NR + END IF + ELSE + IF ( CONNEC ) THEN + MINWRK = MINWRK*( NOBR + 1 ) + ELSE + MINWRK = MINWRK + NR + END IF + END IF + END IF +C + MAXWRK = MINWRK +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -23 + DWORK( 1 ) = MINWRK + END IF + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01AD', -INFO ) + RETURN + END IF +C +C Compress the input-output data. +C Workspace: need c*(M+L)*NOBR, where c is a constant depending +C on the algorithm and the options used +C (see SLICOT Library routine IB01MD); +C prefer larger. +C + CALL IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, Y, + $ LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, INFO ) +C + IF ( INFO.EQ.1 ) THEN +C +C Error return: A fast algorithm was requested (ALG = 'C', 'F') +C in sequential data processing, but it failed. +C + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) ) +C + IF ( .NOT.LAST ) THEN +C +C Return to get new data. +C + RETURN + END IF +C +C Find the singular value decomposition (SVD) giving the system +C order, and perform related preliminary calculations needed for +C computing the system matrices. +C Workspace: need max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), +C if METH = 'M'; +C 5*(M+L)*NOBR+1, if METH = 'N'; +C prefer larger. +C + CALL IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, RCOND, IWORK, + $ DWORK, LDWORK, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) +C + IF ( INFO.EQ.2 ) THEN +C +C Error return: the singular value decomposition (SVD) algorithm +C did not converge. +C + RETURN + END IF +C +C Estimate the system order. +C + CALL IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAX( MAXWRK, INT( DWORK( 1 ) ) ) + RETURN +C +C *** Last line of IB01AD *** + END diff --git a/mex/sources/libslicot/IB01BD.f b/mex/sources/libslicot/IB01BD.f new file mode 100644 index 000000000..011e02d34 --- /dev/null +++ b/mex/sources/libslicot/IB01BD.f @@ -0,0 +1,791 @@ + SUBROUTINE IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMPL, R, + $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, + $ RY, LDRY, S, LDS, K, LDK, TOL, IWORK, DWORK, + $ LDWORK, BWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the system matrices A, C, B, and D, the noise +C covariance matrices Q, Ry, and S, and the Kalman gain matrix K +C of a linear time-invariant state space model, using the +C processed triangular factor R of the concatenated block Hankel +C matrices, provided by SLICOT Library routine IB01AD. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm; +C = 'C': combined method: MOESP algorithm for finding the +C matrices A and C, and N4SID algorithm for +C finding the matrices B and D. +C +C JOB CHARACTER*1 +C Specifies which matrices should be computed, as follows: +C = 'A': compute all system matrices, A, B, C, and D; +C = 'C': compute the matrices A and C only; +C = 'B': compute the matrix B only; +C = 'D': compute the matrices B and D only. +C +C JOBCK CHARACTER*1 +C Specifies whether or not the covariance matrices and the +C Kalman gain matrix are to be computed, as follows: +C = 'C': the covariance matrices only should be computed; +C = 'K': the covariance matrices and the Kalman gain +C matrix should be computed; +C = 'N': the covariance matrices and the Kalman gain matrix +C should not be computed. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C Hankel matrices processed by other routines. NOBR > 1. +C +C N (input) INTEGER +C The order of the system. NOBR > N > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMPL (input) INTEGER +C If JOBCK = 'C' or 'K', the total number of samples used +C for calculating the covariance matrices. +C NSMPL >= 2*(M+L)*NOBR. +C This parameter is not meaningful if JOBCK = 'N'. +C +C R (input/workspace) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part +C of this array must contain the relevant data for the MOESP +C or N4SID algorithms, as constructed by SLICOT Library +C routine IB01AD. Let R_ij, i,j = 1:4, be the +C ij submatrix of R (denoted S in IB01AD), partitioned +C by M*NOBR, L*NOBR, M*NOBR, and L*NOBR rows and +C columns. The submatrix R_22 contains the matrix of left +C singular vectors used. Also needed, for METH = 'N' or +C JOBCK <> 'N', are the submatrices R_11, R_14 : R_44, +C and, for METH = 'M' or 'C' and JOB <> 'C', the +C submatrices R_31 and R_12, containing the processed +C matrices R_1c and R_2c, respectively, as returned by +C SLICOT Library routine IB01AD. +C Moreover, if METH = 'N' and JOB = 'A' or 'C', the +C block-row R_41 : R_43 must contain the transpose of the +C block-column R_14 : R_34 as returned by SLICOT Library +C routine IB01AD. +C The remaining part of R is used as workspace. +C On exit, part of this array is overwritten. Specifically, +C if METH = 'M', R_22 and R_31 are overwritten if +C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, +C and possibly R_11 are overwritten if JOBCK <> 'N'; +C if METH = 'N', all needed submatrices are overwritten. +C The details of the contents of R need not be known if +C this routine is called once just after calling the SLICOT +C Library routine IB01AD. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= 2*(M+L)*NOBR. +C +C A (input or output) DOUBLE PRECISION array, dimension +C (LDA,N) +C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', +C the leading N-by-N part of this array must contain the +C system state matrix. +C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' +C or 'C'), this array need not be set on input. +C On exit, if JOB = 'A' or 'C' and INFO = 0, the +C leading N-by-N part of this array contains the system +C state matrix. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' or 'C' +C and JOB = 'B' or 'D'; +C LDA >= 1, otherwise. +C +C C (input or output) DOUBLE PRECISION array, dimension +C (LDC,N) +C On entry, if METH = 'N' or 'C' and JOB = 'B' or 'D', +C the leading L-by-N part of this array must contain the +C system output matrix. +C If METH = 'M' or (METH = 'N' or 'C' and JOB = 'A' +C or 'C'), this array need not be set on input. +C On exit, if JOB = 'A' or 'C' and INFO = 0, or +C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading +C L-by-N part of this array contains the system output +C matrix. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' or 'C' +C and JOB = 'B' or 'D'; +C LDC >= 1, otherwise. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the +C leading N-by-M part of this array contains the system +C input matrix. If M = 0 or JOB = 'C', this array is +C not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; +C LDB >= 1, if M = 0 or JOB = 'C'. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix. If M = 0 or JOB = 'C' or 'B', this array is +C not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'A' or 'D'; +C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C If JOBCK = 'C' or 'K', the leading N-by-N part of this +C array contains the positive semidefinite state covariance +C matrix. If JOBCK = 'K', this matrix has been used as +C state weighting matrix for computing the Kalman gain. +C This parameter is not referenced if JOBCK = 'N'. +C +C LDQ INTEGER +C The leading dimension of the array Q. +C LDQ >= N, if JOBCK = 'C' or 'K'; +C LDQ >= 1, if JOBCK = 'N'. +C +C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) +C If JOBCK = 'C' or 'K', the leading L-by-L part of this +C array contains the positive (semi)definite output +C covariance matrix. If JOBCK = 'K', this matrix has been +C used as output weighting matrix for computing the Kalman +C gain. +C This parameter is not referenced if JOBCK = 'N'. +C +C LDRY INTEGER +C The leading dimension of the array RY. +C LDRY >= L, if JOBCK = 'C' or 'K'; +C LDRY >= 1, if JOBCK = 'N'. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,L) +C If JOBCK = 'C' or 'K', the leading N-by-L part of this +C array contains the state-output cross-covariance matrix. +C If JOBCK = 'K', this matrix has been used as state- +C output weighting matrix for computing the Kalman gain. +C This parameter is not referenced if JOBCK = 'N'. +C +C LDS INTEGER +C The leading dimension of the array S. +C LDS >= N, if JOBCK = 'C' or 'K'; +C LDS >= 1, if JOBCK = 'N'. +C +C K (output) DOUBLE PRECISION array, dimension ( LDK,L ) +C If JOBCK = 'K', the leading N-by-L part of this array +C contains the estimated Kalman gain matrix. +C If JOBCK = 'C' or 'N', this array is not referenced. +C +C LDK INTEGER +C The leading dimension of the array K. +C LDK >= N, if JOBCK = 'K'; +C LDK >= 1, if JOBCK = 'C' or 'N'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= max(LIW1,LIW2), where +C LIW1 = N, if METH <> 'N' and M = 0 +C or JOB = 'C' and JOBCK = 'N'; +C LIW1 = M*NOBR+N, if METH <> 'N', JOB = 'C', +C and JOBCK <> 'N'; +C LIW1 = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', +C and JOBCK = 'N'; +C LIW1 = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', +C and JOBCK = 'C' or 'K'; +C LIW1 = max(M*NOBR+N,M*(N+L)), if METH = 'N', or METH = 'C' +C and JOB <> 'C'; +C LIW2 = 0, if JOBCK <> 'K'; +C LIW2 = N*N, if JOBCK = 'K'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3), DWORK(4), and +C DWORK(5) contain the reciprocal condition numbers of the +C triangular factors of the following matrices (defined in +C SLICOT Library routine IB01PD and in the lower level +C routines): +C GaL (GaL = Un(1:(s-1)*L,1:n)), +C R_1c (if METH = 'M' or 'C'), +C M (if JOBCK = 'C' or 'K' or METH = 'N'), and +C Q or T (see SLICOT Library routine IB01PY or IB01PX), +C respectively. +C If METH = 'N', DWORK(3) is set to one without any +C calculations. Similarly, if METH = 'M' and JOBCK = 'N', +C DWORK(4) is set to one. If M = 0 or JOB = 'C', +C DWORK(3) and DWORK(5) are set to one. +C If JOBCK = 'K' and INFO = 0, DWORK(6) to DWORK(13) +C contain information about the accuracy of the results when +C computing the Kalman gain matrix, as follows: +C DWORK(6) - reciprocal condition number of the matrix +C U11 of the Nth order system of algebraic +C equations from which the solution matrix X +C of the Riccati equation is obtained; +C DWORK(7) - reciprocal pivot growth factor for the LU +C factorization of the matrix U11; +C DWORK(8) - reciprocal condition number of the matrix +C As = A - S*inv(Ry)*C, which is inverted by +C the standard Riccati solver; +C DWORK(9) - reciprocal pivot growth factor for the LU +C factorization of the matrix As; +C DWORK(10) - reciprocal condition number of the matrix +C Ry; +C DWORK(11) - reciprocal condition number of the matrix +C Ry + C*X*C'; +C DWORK(12) - reciprocal condition number for the Riccati +C equation solution; +C DWORK(13) - forward error bound for the Riccati +C equation solution. +C On exit, if INFO = -30, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( LDW1,LDW2,LDW3 ), where, if METH = 'M', +C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), +C if JOB = 'C' or JOB = 'A' and M = 0; +C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, +C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ +C max( L+M*NOBR, L*NOBR + +C max( 3*L*NOBR+1, M ) ) ), +C if M > 0 and JOB = 'A', 'B', or 'D'; +C LDW2 >= 0, if JOBCK = 'N'; +C LDW2 >= L*NOBR*N+ +C max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), +C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), +C if JOBCK = 'C' or 'K', +C where Aw = N+N*N, if M = 0 or JOB = 'C'; +C Aw = 0, otherwise; +C if METH = 'N', +C LDW1 >= L*NOBR*N+max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ); +C LDW2 >= 0, if M = 0 or JOB = 'C'; +C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ +C max( (N+L)**2, 4*M*(N+L)+1 ), +C if M > 0 and JOB = 'A', 'B', or 'D'; +C and, if METH = 'C', LDW1 as +C max( LDW1 for METH = 'M', JOB = 'C', LDW1 for METH = 'N'), +C and LDW2 for METH = 'N' are used; +C LDW3 >= 0, if JOBCK <> 'K'; +C LDW3 >= max( 4*N*N+2*N*L+L*L+max( 3*L,N*L ), +C 14*N*N+12*N+5 ), if JOBCK = 'K'. +C For good performance, LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (LBWORK) +C LBWORK = 2*N, if JOBCK = 'K'; +C LBWORK = 0, if JOBCK <> 'K'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: a least squares problem to be solved has a +C rank-deficient coefficient matrix; +C = 5: the computed covariance matrices are too small. +C The problem seems to be a deterministic one; the +C gain matrix is set to zero. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge; +C = 3: a singular upper triangular matrix was found; +C = 3+i: if JOBCK = 'K' and the associated Riccati +C equation could not be solved, where i = 1,...,6; +C (see the description of the parameter INFO for the +C SLICOT Library routine SB02RD for the meaning of +C the i values); +C = 10: the QR algorithm did not converge. +C +C METHOD +C +C In the MOESP approach, the matrices A and C are first +C computed from an estimated extended observability matrix [1], +C and then, the matrices B and D are obtained by solving an +C extended linear system in a least squares sense. +C In the N4SID approach, besides the estimated extended +C observability matrix, the solutions of two least squares problems +C are used to build another least squares problem, whose solution +C is needed to compute the system matrices A, C, B, and D. The +C solutions of the two least squares problems are also optionally +C used by both approaches to find the covariance matrices. +C The Kalman gain matrix is obtained by solving a discrete-time +C algebraic Riccati equation. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Van Overschee, P., and De Moor, B. +C N4SID: Two Subspace Algorithms for the Identification +C of Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [3] Van Overschee, P. +C Subspace Identification : Theory - Implementation - +C Applications. +C Ph. D. Thesis, Department of Electrical Engineering, +C Katholieke Universiteit Leuven, Belgium, Feb. 1995. +C +C [4] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C NUMERICAL ASPECTS +C +C The implemented method consists in numerically stable steps. +C +C FURTHER COMMENTS +C +C The covariance matrices are computed using the N4SID approach. +C Therefore, for efficiency reasons, it is advisable to set +C METH = 'N', if the Kalman gain matrix or covariance matrices +C are needed (JOBCK = 'K', or 'C'). When JOBCK = 'N', it could +C be more efficient to use the combined method, METH = 'C'. +C Often, this combination will also provide better accuracy than +C MOESP algorithm. +C In some applications, it is useful to compute the system matrices +C using two calls to this routine, the first one with JOB = 'C', +C and the second one with JOB = 'B' or 'D'. This is slightly less +C efficient than using a single call with JOB = 'A', because some +C calculations are repeated. If METH = 'N', all the calculations +C at the first call are performed again at the second call; +C moreover, it is required to save the needed submatrices of R +C before the first call and restore them before the second call. +C If the covariance matrices and/or the Kalman gain are desired, +C JOBCK should be set to 'C' or 'K' at the second call. +C If B and D are both needed, they should be computed at once. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. +C +C REVISIONS +C +C March 2000, August 2000, Sept. 2001, March 2005. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDK, LDQ, + $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL + CHARACTER JOB, JOBCK, METH +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), K(LDK, *), Q(LDQ, *), R(LDR, *), + $ RY(LDRY, *), S(LDS, *) + INTEGER IWORK( * ) + LOGICAL BWORK( * ) +C .. Local Scalars .. + DOUBLE PRECISION FERR, RCOND, RCONDR, RNORM, SEP + INTEGER I, IA, IAW, IC, ID, IERR, IFACT, IG, IK, IO, + $ IQ, IR, IS, IT, IV, IWARNL, IWI, IWR, IX, + $ JWORK, LDUNN, LL, LMMNOL, LMNOBR, LNOBR, + $ MAXWRK, MINWRK, MNOBR, MNOBRN, N2, NL, NN, NPL, + $ NR + CHARACTER JOBBD, JOBCOV, JOBCV + LOGICAL COMBIN, MOESP, N4SID, WITHAL, WITHB, WITHC, + $ WITHCO, WITHD, WITHK +C .. Local Arrays .. + DOUBLE PRECISION RCND(8) + INTEGER OUFACT(2) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, IB01PD, MA02AD, SB02MT, SB02ND, + $ SB02RD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + COMBIN = LSAME( METH, 'C' ) + WITHAL = LSAME( JOB, 'A' ) + WITHC = LSAME( JOB, 'C' ) .OR. WITHAL + WITHD = LSAME( JOB, 'D' ) .OR. WITHAL + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + WITHK = LSAME( JOBCK, 'K' ) + WITHCO = LSAME( JOBCK, 'C' ) .OR. WITHK + MNOBR = M*NOBR + LNOBR = L*NOBR + LMNOBR = LNOBR + MNOBR + MNOBRN = MNOBR + N + LDUNN = ( LNOBR - L )*N + LMMNOL = LNOBR + 2*MNOBR + L + NR = LMNOBR + LMNOBR + NPL = N + L + N2 = N + N + NN = N*N + NL = N*L + LL = L*L + MINWRK = 1 + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID .OR. COMBIN ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN + INFO = -2 + ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCK, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( NOBR.LE.1 ) THEN + INFO = -4 + ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( L.LE.0 ) THEN + INFO = -7 + ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN + INFO = -8 + ELSE IF( LDR.LT.NR ) THEN + INFO = -10 + ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) + $ .AND. LDA.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) ) + $ .AND. LDC.LT.L ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) + $ THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -18 + ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN + INFO = -20 + ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN + INFO = -22 + ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN + INFO = -24 + ELSE IF( LDK.LT.1 .OR. ( WITHK .AND. LDK.LT.N ) ) THEN + INFO = -26 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance.) +C + IAW = 0 + MINWRK = LDUNN + 4*N + IF( .NOT.N4SID ) THEN + ID = 0 + IF( WITHC ) THEN + MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) + END IF + ELSE + ID = N + END IF +C + IF( ( M.GT.0 .AND. WITHB ) .OR. .NOT.MOESP ) THEN + MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) + IF ( MOESP ) + $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + + $ MAX( L + MNOBR, LNOBR + + $ MAX( 3*LNOBR + 1, M ) ) ) + ELSE + IF( .NOT.N4SID ) + $ IAW = N + NN + END IF +C + IF( .NOT.MOESP .OR. WITHCO ) THEN + MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), + $ ID + 4*MNOBRN + 1, ID + MNOBRN + NPL ) + IF( .NOT.MOESP .AND. M.GT.0 .AND. WITHB ) + $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + + $ MAX( NPL**2, 4*M*NPL + 1 ) ) + MINWRK = LNOBR*N + MINWRK + END IF +C + IF( WITHK ) THEN + MINWRK = MAX( MINWRK, 4*NN + 2*NL + LL + MAX( 3*L, NL ), + $ 14*NN + 12*N + 5 ) + END IF +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -30 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01BD', -INFO ) + RETURN + END IF +C + IF ( .NOT.WITHK ) THEN + JOBCV = JOBCK + ELSE + JOBCV = 'C' + END IF +C + IO = 1 + IF ( .NOT.MOESP .OR. WITHCO ) THEN + JWORK = IO + LNOBR*N + ELSE + JWORK = IO + END IF + MAXWRK = MINWRK +C +C Call the computational routine for estimating system matrices. +C + IF ( .NOT.COMBIN ) THEN + CALL IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, LDR, + $ A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, RY, LDRY, + $ S, LDS, DWORK(IO), LNOBR, TOL, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARN, INFO ) +C + ELSE +C + IF ( WITHC ) THEN + IF ( WITHAL ) THEN + JOBCOV = 'N' + ELSE + JOBCOV = JOBCV + END IF + CALL IB01PD( 'MOESP', 'C and A', JOBCOV, NOBR, N, M, L, + $ NSMPL, R, LDR, A, LDA, C, LDC, B, LDB, D, LDD, + $ Q, LDQ, RY, LDRY, S, LDS, DWORK(IO), LNOBR, + $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + IWARN = MAX( IWARN, IWARNL ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF ( WITHB ) THEN + IF ( .NOT.WITHAL ) THEN + JOBBD = JOB + ELSE + JOBBD = 'D' + END IF + CALL IB01PD( 'N4SID', JOBBD, JOBCV, NOBR, N, M, L, NSMPL, R, + $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, + $ RY, LDRY, S, LDS, DWORK(IO), LNOBR, TOL, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFO ) + IWARN = MAX( IWARN, IWARNL ) + END IF + END IF +C + IF ( INFO.NE.0 ) + $ RETURN + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + DO 10 I = 1, 4 + RCND(I) = DWORK(JWORK+I) + 10 CONTINUE +C + IF ( WITHK ) THEN + IF ( IWARN.EQ.5 ) THEN +C +C The problem seems to be a deterministic one. Set the Kalman +C gain to zero, set accuracy parameters and return. +C + CALL DLASET( 'Full', N, L, ZERO, ZERO, K, LDK ) +C + DO 20 I = 6, 12 + DWORK(I) = ONE + 20 CONTINUE +C + DWORK(13) = ZERO + ELSE +C +C Compute the Kalman gain matrix. +C +C Convert the optimal problem with coupling weighting terms +C to a standard problem. +C Workspace: need 4*N*N+2*N*L+L*L+max( 3*L,N*L ); +C prefer larger. +C + IX = 1 + IQ = IX + NN + IA = IQ + NN + IG = IA + NN + IC = IG + NN + IR = IC + NL + IS = IR + LL + JWORK = IS + NL +C + CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) + CALL DLACPY( 'Upper', N, N, Q, LDQ, DWORK(IQ), N ) + CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) + CALL DLACPY( 'Full', N, L, S, LDS, DWORK(IS), N ) +C + CALL SB02MT( 'G needed', 'Nonzero S', 'Not factored', + $ 'Upper', N, L, DWORK(IA), N, DWORK(IC), N, + $ DWORK(IQ), N, DWORK(IR), L, DWORK(IS), N, + $ IWORK, IFACT, DWORK(IG), N, IWORK(L+1), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 3 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + RCONDR = DWORK(JWORK+1) +C +C Solve the Riccati equation. +C Workspace: need 14*N*N+12*N+5; +C prefer larger. +C + IT = IC + IV = IT + NN + IWR = IV + NN + IWI = IWR + N2 + IS = IWI + N2 + JWORK = IS + N2*N2 +C + CALL SB02RD( 'All', 'Discrete', 'Direct', 'NoTranspose', + $ 'Upper', 'General scaling', 'Unstable first', + $ 'Not factored', 'Reduced', N, DWORK(IA), N, + $ DWORK(IT), N, DWORK(IV), N, DWORK(IG), N, + $ DWORK(IQ), N, DWORK(IX), N, SEP, RCOND, FERR, + $ DWORK(IWR), DWORK(IWI), DWORK(IS), N2, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, BWORK, IERR ) +C + IF ( IERR.NE.0 .AND. IERR.LT.7 ) THEN + INFO = IERR + 3 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + DO 30 I = 1, 4 + RCND(I+4) = DWORK(JWORK+I) + 30 CONTINUE +C +C Compute the gain matrix. +C Workspace: need 2*N*N+2*N*L+L*L+3*L; +C prefer larger. +C + IA = IX + NN + IC = IA + NN + IR = IC + NL + IK = IR + LL + JWORK = IK + NL +C + CALL MA02AD( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL MA02AD( 'Full', L, N, C, LDC, DWORK(IC), N ) + CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L ) +C + CALL SB02ND( 'Discrete', 'NotFactored', 'Upper', + $ 'Nonzero S', N, L, 0, DWORK(IA), N, DWORK(IC), + $ N, DWORK(IR), L, IWORK, S, LDS, DWORK(IX), N, + $ RNORM, DWORK(IK), L, OUFACT, IWORK(L+1), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C + IF ( IERR.NE.0 ) THEN + IF ( IERR.LE.L+1 ) THEN + INFO = 3 + ELSE IF ( IERR.EQ.L+2 ) THEN + INFO = 10 + END IF + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + CALL MA02AD( 'Full', L, N, DWORK(IK), L, K, LDK ) +C +C Set the accuracy parameters. +C + DWORK(11) = DWORK(JWORK+1) +C + DO 40 I = 6, 9 + DWORK(I) = RCND(I-1) + 40 CONTINUE +C + DWORK(10) = RCONDR + DWORK(12) = RCOND + DWORK(13) = FERR + END IF + END IF +C +C Return optimal workspace in DWORK(1) and the remaining +C reciprocal condition numbers in the next locations. +C + DWORK(1) = MAXWRK +C + DO 50 I = 2, 5 + DWORK(I) = RCND(I-1) + 50 CONTINUE +C + RETURN +C +C *** Last line of IB01BD *** + END diff --git a/mex/sources/libslicot/IB01CD.f b/mex/sources/libslicot/IB01CD.f new file mode 100644 index 000000000..001c6dcca --- /dev/null +++ b/mex/sources/libslicot/IB01CD.f @@ -0,0 +1,823 @@ + SUBROUTINE IB01CD( JOBX0, COMUSE, JOB, N, M, L, NSMP, A, LDA, B, + $ LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, V, + $ LDV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the initial state and, optionally, the system matrices +C B and D of a linear time-invariant (LTI) discrete-time system, +C given the system matrices (A,B,C,D), or (when B and D are +C estimated) only the matrix pair (A,C), and the input and output +C trajectories of the system. The model structure is : +C +C x(k+1) = Ax(k) + Bu(k), k >= 0, +C y(k) = Cx(k) + Du(k), +C +C where x(k) is the n-dimensional state vector (at time k), +C u(k) is the m-dimensional input vector, +C y(k) is the l-dimensional output vector, +C and A, B, C, and D are real matrices of appropriate dimensions. +C The input-output data can internally be processed sequentially. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX0 CHARACTER*1 +C Specifies whether or not the initial state should be +C computed, as follows: +C = 'X': compute the initial state x(0); +C = 'N': do not compute the initial state (possibly, +C because x(0) is known to be zero). +C +C COMUSE CHARACTER*1 +C Specifies whether the system matrices B and D should be +C computed or used, as follows: +C = 'C': compute the system matrices B and D, as specified +C by JOB; +C = 'U': use the system matrices B and D, as specified by +C JOB; +C = 'N': do not compute/use the matrices B and D. +C If JOBX0 = 'N' and COMUSE <> 'N', then x(0) is set +C to zero. +C If JOBX0 = 'N' and COMUSE = 'N', then x(0) is +C neither computed nor set to zero. +C +C JOB CHARACTER*1 +C If COMUSE = 'C' or 'U', specifies which of the system +C matrices B and D should be computed or used, as follows: +C = 'B': compute/use the matrix B only (D is known to be +C zero); +C = 'D': compute/use the matrices B and D. +C The value of JOB is irrelevant if COMUSE = 'N' or if +C JOBX0 = 'N' and COMUSE = 'U'. +C The combinations of options, the data used, and the +C returned results, are given in the table below, where +C '*' denotes an irrelevant value. +C +C JOBX0 COMUSE JOB Data used Returned results +C ---------------------------------------------------------- +C X C B A,C,u,y x,B +C X C D A,C,u,y x,B,D +C N C B A,C,u,y x=0,B +C N C D A,C,u,y x=0,B,D +C ---------------------------------------------------------- +C X U B A,B,C,u,y x +C X U D A,B,C,D,u,y x +C N U * - x=0 +C ---------------------------------------------------------- +C X N * A,C,y x +C N N * - - +C ---------------------------------------------------------- +C +C For JOBX0 = 'N' and COMUSE = 'N', the routine just +C sets DWORK(1) to 2 and DWORK(2) to 1, and returns +C (see the parameter DWORK). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). +C NSMP >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; +C NSMP >= N, if JOBX0 = 'X' and COMUSE <> 'C'; +C NSMP >= N*M + a + e, if COMUSE = 'C', +C where a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'; +C e = 0, if JOBX0 = 'X' and JOB = 'B'; +C e = 1, if JOBX0 = 'N' and JOB = 'B'; +C e = M, if JOB = 'D'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If JOBX0 = 'X' or COMUSE = 'C', the leading N-by-N +C part of this array must contain the system state matrix A. +C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this +C array is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C'; +C LDA >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. +C +C B (input or output) DOUBLE PRECISION array, dimension +C (LDB,M) +C If JOBX0 = 'X' and COMUSE = 'U', B is an input +C parameter and, on entry, the leading N-by-M part of this +C array must contain the system input matrix B. +C If COMUSE = 'C', B is an output parameter and, on exit, +C if INFO = 0, the leading N-by-M part of this array +C contains the estimated system input matrix B. +C If min(N,M) = 0, or JOBX0 = 'N' and COMUSE = 'U', +C or COMUSE = 'N', this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N), if M > 0, COMUSE = 'U', JOBX0 = 'X', +C or M > 0, COMUSE = 'C'; +C LDB >= 1, if min(N,M) = 0, or COMUSE = 'N', +C or JOBX0 = 'N' and COMUSE = 'U'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If JOBX0 = 'X' or COMUSE = 'C', the leading L-by-N +C part of this array must contain the system output +C matrix C. +C If N = 0, or JOBX0 = 'N' and COMUSE <> 'C', this +C array is not referenced. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= L, if N > 0, and JOBX0 = 'X' or COMUSE = 'C'; +C LDC >= 1, if N = 0, or JOBX0 = 'N' and COMUSE <> 'C'. +C +C D (input or output) DOUBLE PRECISION array, dimension +C (LDD,M) +C If JOBX0 = 'X', COMUSE = 'U', and JOB = 'D', D is an +C input parameter and, on entry, the leading L-by-M part of +C this array must contain the system input-output matrix D. +C If COMUSE = 'C' and JOB = 'D', D is an output +C parameter and, on exit, if INFO = 0, the leading +C L-by-M part of this array contains the estimated system +C input-output matrix D. +C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or +C COMUSE = 'N', or JOB = 'B', this array is not +C referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0, JOBX0 = 'X', COMUSE = 'U', and +C JOB = 'D', or +C if M > 0, COMUSE = 'C', and JOB = 'D'; +C LDD >= 1, if M = 0, or JOBX0 = 'N' and COMUSE = 'U', +C or COMUSE = 'N', or JOB = 'B'. +C +C U (input or input/output) DOUBLE PRECISION array, dimension +C (LDU,M) +C On entry, if COMUSE = 'C', or JOBX0 = 'X' and +C COMUSE = 'U', the leading NSMP-by-M part of this array +C must contain the t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C On exit, if COMUSE = 'C' and JOB = 'D', the leading +C NSMP-by-M part of this array contains details of the +C QR factorization of the t-by-m matrix U, possibly +C computed sequentially (see METHOD). +C If COMUSE = 'C' and JOB = 'B', or COMUSE = 'U', this +C array is unchanged on exit. +C If M = 0, or JOBX0 = 'N' and COMUSE = 'U', or +C COMUSE = 'N', this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,NSMP), if M > 0 and COMUSE = 'C' or +C JOBX0 = 'X' and COMUSE = 'U; +C LDU >= 1, if M = 0, or COMUSE = 'N', or +C JOBX0 = 'N' and COMUSE = 'U'. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C On entry, if JOBX0 = 'X' or COMUSE = 'C', the leading +C NSMP-by-L part of this array must contain the t-by-l +C output-data sequence matrix Y, Y = [y_1 y_2 ... y_l]. +C Column j of Y contains the NSMP values of the j-th +C output component for consecutive time increments. +C If JOBX0 = 'N' and COMUSE <> 'C', this array is not +C referenced. +C +C LDY INTEGER +C The leading dimension of the array Y. +C LDY >= MAX(1,NSMP), if JOBX0 = 'X' or COMUSE = 'C; +C LDY >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0 and JOBX0 = 'X', this array contains the +C estimated initial state of the system, x(0). +C If JOBX0 = 'N' and COMUSE = 'C', this array is used as +C workspace and finally it is set to zero. +C If JOBX0 = 'N' and COMUSE = 'U', then x(0) is set to +C zero without any calculations. +C If JOBX0 = 'N' and COMUSE = 'N', this array is not +C referenced. +C +C V (output) DOUBLE PRECISION array, dimension (LDV,N) +C On exit, if INFO = 0 or 2, JOBX0 = 'X' or +C COMUSE = 'C', the leading N-by-N part of this array +C contains the orthogonal matrix V of a real Schur +C factorization of the matrix A. +C If JOBX0 = 'N' and COMUSE <> 'C', this array is not +C referenced. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,N), if JOBX0 = 'X' or COMUSE = 'C; +C LDV >= 1, if JOBX0 = 'N' and COMUSE <> 'C'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; a matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then EPS is used +C instead, where EPS is the relative machine precision +C (see LAPACK Library routine DLAMCH). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= 0, if JOBX0 = 'N' and COMUSE <> 'C'; +C LIWORK >= N, if JOBX0 = 'X' and COMUSE <> 'C'; +C LIWORK >= N*M + a, if COMUSE = 'C' and JOB = 'B', +C LIWORK >= max(N*M + a,M), if COMUSE = 'C' and JOB = 'D', +C with a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; DWORK(2) contains the reciprocal condition +C number of the triangular factor of the QR factorization of +C the matrix W2, if COMUSE = 'C', or of the matrix +C Gamma, if COMUSE = 'U' (see METHOD); if JOBX0 = 'N' +C and COMUSE <> 'C', DWORK(2) is set to one; +C if COMUSE = 'C', M > 0, and JOB = 'D', DWORK(3) +C contains the reciprocal condition number of the triangular +C factor of the QR factorization of U; denoting +C g = 2, if JOBX0 = 'X' and COMUSE <> 'C' or +C COMUSE = 'C' and M = 0 or JOB = 'B', +C g = 3, if COMUSE = 'C' and M > 0 and JOB = 'D', +C then DWORK(i), i = g+1:g+N*N, +C DWORK(j), j = g+1+N*N:g+N*N+L*N, and +C DWORK(k), k = g+1+N*N+L*N:g+N*N+L*N+N*M, +C contain the transformed system matrices At, Ct, and Bt, +C respectively, corresponding to the real Schur form of the +C given system state matrix A, i.e., +C At = V'*A*V, Bt = V'*B, Ct = C*V. +C The matrices At, Ct, Bt are not computed if JOBX0 = 'N' +C and COMUSE <> 'C'. +C On exit, if INFO = -26, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2, if JOBX0 = 'N' and COMUSE <> 'C', or +C if max( N, M ) = 0. +C Otherwise, +C LDWORK >= LDW1 + N*( N + M + L ) + +C max( 5*N, LDW1, min( LDW2, LDW3 ) ), +C where, if COMUSE = 'C', then +C LDW1 = 2, if M = 0 or JOB = 'B', +C LDW1 = 3, if M > 0 and JOB = 'D', +C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), +C LDW2 = LDWa, if M = 0 or JOB = 'B', +C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C LDWb = (b + r)*(r + 1) + +C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), +C LDW3 = LDWb, if M = 0 or JOB = 'B', +C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C r = N*M + a, +C a = 0, if JOBX0 = 'N', +C a = N, if JOBX0 = 'X'; +C b = 0, if JOB = 'B', +C b = L*M, if JOB = 'D'; +C c = 0, if JOBX0 = 'N', +C c = L*N, if JOBX0 = 'X'; +C d = 0, if JOBX0 = 'N', +C d = 2*N*N + N, if JOBX0 = 'X'; +C f = 2*r, if JOB = 'B' or M = 0, +C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; +C q = b + r*L; +C and, if JOBX0 = 'X' and COMUSE <> 'C', then +C LDW1 = 2, +C LDW2 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), +C LDW3 = N*(N + 1) + 2*N + max( q*(N + 1) + 2*N*N + L*N, +C 4*N ), +C q = N*L. +C For good performance, LDWORK should be larger. +C If LDWORK >= LDW2, or if COMUSE = 'C' and +C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + +C max( d, f ), +C then standard QR factorizations of the matrices U and/or +C W2, if COMUSE = 'C', or of the matrix Gamma, if +C JOBX0 = 'X' and COMUSE <> 'C' (see METHOD), are used. +C Otherwise, the QR factorizations are computed sequentially +C by performing NCYCLE cycles, each cycle (except possibly +C the last one) processing s < t samples, where s is +C chosen by equating LDWORK to the first term of LDWb, +C if COMUSE = 'C', or of LDW3, if COMUSE <> 'C', for +C q replaced by s*L. (s is larger than or equal to the +C minimum value of NSMP.) The computational effort may +C increase and the accuracy may slightly decrease with the +C decrease of s. Recommended value is LDWORK = LDW2, +C assuming a large enough cache size, to also accommodate +C A, (B,) C, (D,) U, and Y. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix; +C = 6: the matrix A is unstable; the estimated x(0) +C and/or B and D could be inaccurate. +C NOTE: the value 4 of IWARN has no significance for the +C identification problem. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the QR algorithm failed to compute all the +C eigenvalues of the matrix A (see LAPACK Library +C routine DGEES); the locations DWORK(i), for +C i = g+1:g+N*N, contain the partially converged +C Schur form; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C Matrix A is initially reduced to a real Schur form, A = V*At*V', +C and the given system matrices are transformed accordingly. For the +C reduced system, an extension and refinement of the method in [1,2] +C is used. Specifically, for JOBX0 = 'X', COMUSE = 'C', and +C JOB = 'D', denoting +C +C X = [ vec(D')' vec(B)' x0' ]', +C +C where vec(M) is the vector obtained by stacking the columns of +C the matrix M, then X is the least squares solution of the +C system S*X = vec(Y), with the matrix S = [ diag(U) W ], +C defined by +C +C ( U | | ... | | | ... | | ) +C ( U | 11 | ... | n1 | 12 | ... | nm | ) +C S = ( : | y | ... | y | y | ... | y | P*Gamma ), +C ( : | | ... | | | ... | | ) +C ( U | | ... | | | ... | | ) +C ij +C diag(U) having L block rows and columns. In this formula, y +C are the outputs of the system for zero initial state computed +C using the following model, for j = 1:m, and for i = 1:n, +C ij ij ij +C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, +C +C ij ij +C y (k) = Cx (k), +C +C where e_i is the i-th n-dimensional unit vector, Gamma is +C given by +C +C ( C ) +C ( C*A ) +C Gamma = ( C*A^2 ), +C ( : ) +C ( C*A^(t-1) ) +C +C and P is a permutation matrix that groups together the rows of +C Gamma depending on the same row of C, namely +C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. +C The first block column, diag(U), is not explicitly constructed, +C but its structure is exploited. The last block column is evaluated +C using powers of A with exponents 2^k. No interchanges are applied. +C A special QR decomposition of the matrix S is computed. Let +C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where +C r is M-by-M. Then, diag(q') is applied to W and vec(Y). +C The block-rows of S and vec(Y) are implicitly permuted so that +C matrix S becomes +C +C ( diag(r) W1 ) +C ( 0 W2 ), +C +C where W1 has L*M rows. Then, the QR decomposition of W2 is +C computed (sequentially, if M > 0) and used to obtain B and x0. +C The intermediate results and the QR decomposition of U are +C needed to find D. If a triangular factor is too ill conditioned, +C then singular value decomposition (SVD) is employed. SVD is not +C generally needed if the input sequence is sufficiently +C persistently exciting and NSMP is large enough. +C If the matrix W cannot be stored in the workspace (i.e., +C LDWORK < LDW2), the QR decompositions of W2 and U are +C computed sequentially. +C For JOBX0 = 'N' and COMUSE = 'C', or JOB = 'B', a simpler +C problem is solved efficiently. +C +C For JOBX0 = 'X' and COMUSE <> 'C', a simpler method is used. +C Specifically, the output y0(k) of the system for zero initial +C state is computed for k = 0, 1, ..., t-1 using the given model. +C Then the following least squares problem is solved for x(0) +C +C ( y(0) - y0(0) ) +C ( y(1) - y0(1) ) +C Gamma * x(0) = ( : ). +C ( : ) +C ( y(t-1) - y0(t-1) ) +C +C The coefficient matrix Gamma is evaluated using powers of A with +C exponents 2^k. The QR decomposition of this matrix is computed. +C If its triangular factor R is too ill conditioned, then singular +C value decomposition of R is used. +C If the coefficient matrix cannot be stored in the workspace (i.e., +C LDWORK < LDW2), the QR decomposition is computed sequentially. +C +C +C REFERENCES +C +C [1] Verhaegen M., and Varga, A. +C Some Experience with the MOESP Class of Subspace Model +C Identification Methods in Identifying the BO105 Helicopter. +C Report TR R165-94, DLR Oberpfaffenhofen, 1994. +C +C [2] Sima, V., and Varga, A. +C RASP-IDENT : Subspace Model Identification Programs. +C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., +C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C FURTHER COMMENTS +C +C The algorithm for computing the system matrices B and D is +C less efficient than the MOESP or N4SID algorithms implemented in +C SLICOT Library routines IB01BD/IB01PD, because a large least +C squares problem has to be solved, but the accuracy is better, as +C the computed matrices B and D are fitted to the input and +C output trajectories. However, if matrix A is unstable, the +C computed matrices B and D could be inaccurate. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, LDV, + $ LDWORK, LDY, M, N, NSMP + CHARACTER COMUSE, JOB, JOBX0 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), U(LDU, *), V(LDV, *), X0(*), + $ Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, RCONDU + INTEGER I, IA, IB, IC, IERR, IQ, ISIZE, ITAU, IWARNL, + $ IWI, IWR, JWORK, LDW, LDW2, LDW3, LM, LN, + $ MAXWRK, MINSMP, MINWLS, MINWRK, MTMP, N2M, + $ NCOL, NCP1, NM, NN, NSMPL + LOGICAL COMPBD, USEBD, MAXDIA, MAXDIM, WITHB, WITHD, + $ WITHX0 + CHARACTER JOBD +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, IB01QD, IB01RD, + $ TB01WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C +C Check the input parameters. +C + WITHX0 = LSAME( JOBX0, 'X' ) + COMPBD = LSAME( COMUSE, 'C' ) + USEBD = LSAME( COMUSE, 'U' ) + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + MAXDIM = ( WITHX0 .AND. USEBD ) .OR. COMPBD + MAXDIA = WITHX0 .OR. COMPBD +C + IWARN = 0 + INFO = 0 + LDW = MAX( 1, N ) + LM = L*M + LN = L*N + NN = N*N + NM = N*M + N2M = N*NM + IF( COMPBD ) THEN + NCOL = NM + IF( WITHX0 ) + $ NCOL = NCOL + N + MINSMP = NCOL + IF( WITHD ) THEN + MINSMP = MINSMP + M + IQ = MINSMP + ELSE IF ( .NOT.WITHX0 ) THEN + IQ = MINSMP + MINSMP = MINSMP + 1 + ELSE + IQ = MINSMP + END IF + ELSE + NCOL = N + IF( WITHX0 ) THEN + MINSMP = N + ELSE + MINSMP = 0 + END IF + IQ = MINSMP + END IF +C + IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( COMPBD .OR. USEBD .OR. LSAME( COMUSE, 'N' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.WITHB ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LE.0 ) THEN + INFO = -6 + ELSE IF( NSMP.LT.MINSMP ) THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. ( MAXDIA .AND. LDA.LT.LDW ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDB.LT.LDW ) ) + $ THEN + INFO = -11 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. MAXDIA .AND. LDC.LT.L ) ) + $ THEN + INFO = -13 + ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. WITHD .AND. + $ LDD.LT.L ) ) THEN + INFO = -15 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDU.LT.NSMP ) ) + $ THEN + INFO = -17 + ELSE IF( LDY.LT.1 .OR. ( MAXDIA .AND. LDY.LT.NSMP ) ) THEN + INFO = -19 + ELSE IF( LDV.LT.1 .OR. ( MAXDIA .AND. LDV.LT.LDW ) ) THEN + INFO = -22 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -23 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN + MINWRK = 2 + ELSE + NSMPL = NSMP*L + IQ = IQ*L + NCP1 = NCOL + 1 + ISIZE = NSMPL*NCP1 + IF ( COMPBD ) THEN + IF ( N.GT.0 .AND. WITHX0 ) THEN + IC = 2*NN + N + ELSE + IC = 0 + END IF + ELSE + IC = 2*NN + END IF + MINWLS = NCOL*NCP1 + IF ( COMPBD ) THEN + IF ( WITHD ) + $ MINWLS = MINWLS + LM*NCP1 + IF ( M.GT.0 .AND. WITHD ) THEN + IA = M + MAX( 2*NCOL, M ) + ELSE + IA = 2*NCOL + END IF + ITAU = N2M + MAX( IC, IA ) + IF ( WITHX0 ) + $ ITAU = ITAU + LN + LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) + LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) + IF ( M.GT.0 .AND. WITHD ) THEN + LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) + LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) + IA = 3 + ELSE + IA = 2 + END IF + ELSE + ITAU = IC + LN + LDW2 = ISIZE + 2*N + MAX( IC, 4*N ) + LDW3 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) + IA = 2 + END IF + MINWRK = IA + NN + NM + LN + MAX( 5*N, IA, MIN( LDW2, LDW3 ) ) +C + IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN + MAXWRK = MAX( 5*N, IA ) + IF ( COMPBD ) THEN + IF ( M.GT.0 .AND. WITHD ) THEN + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, + $ M, -1, -1 ), + $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', + $ ' ', NSMP-M, NCOL, -1, -1 ) ) ) + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', + $ NSMP, NCP1, M, -1 ), + $ NCOL + ILAENV( 1, 'DORMQR', 'LT', + $ NSMP-M, 1, NCOL, -1 ) ) ) + ELSE + MAXWRK = MAX( MAXWRK, ISIZE + N + NCOL + + $ MAX( NCOL*ILAENV( 1, 'DGEQRF', + $ ' ', NSMPL, NCOL, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', + $ NSMPL, 1, NCOL, -1 ) ) ) + END IF + ELSE + MAXWRK = MAX( MAXWRK, ISIZE + 2*N + + $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', + $ NSMPL, N, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', + $ NSMPL, 1, N, -1 ) ) ) + END IF + MAXWRK = IA + NN + NM + LN + MAXWRK + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + END IF +C + IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN + INFO = -26 + DWORK(1) = MINWRK + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN + DWORK(2) = ONE + IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) THEN + DWORK(1) = THREE + DWORK(3) = ONE + ELSE + DWORK(1) = TWO + END IF + IF ( N.GT.0 .AND. USEBD ) THEN + DUM(1) = ZERO + CALL DCOPY( N, DUM, 0, X0, 1 ) + END IF + RETURN + END IF +C +C Compute the Schur factorization of A and transform the other +C given system matrices accordingly. +C Workspace: need g + N*N + L*N + N*M + 5*N, where +C g = 2, if M = 0, COMUSE = 'C', or JOB = 'B', +C g = 3, if M > 0, COMUSE = 'C', and JOB = 'D', +C g = 2, if JOBX0 = 'X' and COMUSE <> 'C'; +C prefer larger. +C + IA = IA + 1 + IC = IA + NN + IB = IC + LN + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), LDW ) + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IC), L ) +C + IF ( USEBD ) THEN + MTMP = M + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(IB), LDW ) + ELSE + MTMP = 0 + END IF + IWR = IB + NM + IWI = IWR + N + JWORK = IWI + N +C + CALL TB01WD( N, MTMP, L, DWORK(IA), LDW, DWORK(IB), LDW, + $ DWORK(IC), L, V, LDV, DWORK(IWR), DWORK(IWI), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 1 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) +C + DO 10 I = IWR, IWI - 1 + IF( DLAPY2( DWORK(I), DWORK(I+N) ).GE.ONE ) + $ IWARN = 6 + 10 CONTINUE +C + JWORK = IWR +C +C Estimate x(0) and/or the system matrices B and D. +C Workspace: need g + N*N + L*N + N*M + +C max( g, min( LDW2, LDW3 ) ) (see LDWORK); +C prefer larger. +C + IF ( COMPBD ) THEN + CALL IB01QD( JOBX0, JOB, N, M, L, NSMP, DWORK(IA), LDW, + $ DWORK(IC), L, U, LDU, Y, LDY, X0, DWORK(IB), LDW, + $ D, LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) +C + IF( INFO.EQ.0 ) THEN + IF ( M.GT.0 .AND. WITHD ) + $ RCONDU = DWORK(JWORK+2) +C +C Compute the system input matrix B corresponding to the +C original system. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, N, ONE, + $ V, LDV, DWORK(IB), LDW, ZERO, B, LDB ) + END IF + ELSE + IF ( WITHD ) THEN + JOBD = 'N' + ELSE + JOBD = 'Z' + END IF +C + CALL IB01RD( JOBD, N, MTMP, L, NSMP, DWORK(IA), LDW, DWORK(IB), + $ LDW, DWORK(IC), L, D, LDD, U, LDU, Y, LDY, X0, + $ TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARNL, + $ INFO ) + END IF + IWARN = MAX( IWARN, IWARNL ) +C + IF( INFO.EQ.0 ) THEN + RCOND = DWORK(JWORK+1) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF( WITHX0 ) THEN +C +C Transform the initial state estimate to obtain the initial +C state corresponding to the original system. +C Workspace: need g + N*N + L*N + N*M + N. +C + CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, X0, 1, ZERO, + $ DWORK(JWORK), 1 ) + CALL DCOPY( N, DWORK(JWORK), 1, X0, 1 ) + END IF +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND + IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) + $ DWORK(3) = RCONDU + END IF + RETURN +C +C *** End of IB01CD *** + END diff --git a/mex/sources/libslicot/IB01MD.f b/mex/sources/libslicot/IB01MD.f new file mode 100644 index 000000000..d76b4af38 --- /dev/null +++ b/mex/sources/libslicot/IB01MD.f @@ -0,0 +1,1433 @@ + SUBROUTINE IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, + $ LDU, Y, LDY, R, LDR, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct an upper triangular factor R of the concatenated +C block Hankel matrices using input-output data. The input-output +C data can, optionally, be processed sequentially. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C ALG CHARACTER*1 +C Specifies the algorithm for computing the triangular +C factor R, as follows: +C = 'C': Cholesky algorithm applied to the correlation +C matrix of the input-output data; +C = 'F': Fast QR algorithm; +C = 'Q': QR algorithm applied to the concatenated block +C Hankel matrices. +C +C BATCH CHARACTER*1 +C Specifies whether or not sequential data processing is to +C be used, and, for sequential processing, whether or not +C the current data block is the first block, an intermediate +C block, or the last block, as follows: +C = 'F': the first block in sequential data processing; +C = 'I': an intermediate block in sequential data +C processing; +C = 'L': the last block in sequential data processing; +C = 'O': one block only (non-sequential data processing). +C NOTE that when 100 cycles of sequential data processing +C are completed for BATCH = 'I', a warning is +C issued, to prevent for an infinite loop. +C +C CONCT CHARACTER*1 +C Specifies whether or not the successive data blocks in +C sequential data processing belong to a single experiment, +C as follows: +C = 'C': the current data block is a continuation of the +C previous data block and/or it will be continued +C by the next data block; +C = 'N': there is no connection between the current data +C block and the previous and/or the next ones. +C This parameter is not used if BATCH = 'O'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C block Hankel matrices to be processed. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, +C the estimated dimension of state vector.) +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C When M = 0, no system inputs are processed. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). (When sequential data processing is used, +C NSMP is the number of samples of the current data +C block.) +C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential +C processing; +C NSMP >= 2*NOBR, for sequential processing. +C The total number of samples when calling the routine with +C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. +C The NSMP argument may vary from a cycle to another in +C sequential data processing, but NOBR, M, and L should +C be kept constant. For efficiency, it is advisable to use +C NSMP as large as possible. +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NSMP-by-M part of this array must contain the +C t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= NSMP, if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= NSMP. +C +C R (output or input/output) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On exit, if INFO = 0 and ALG = 'Q', or (ALG = 'C' or 'F', +C and BATCH = 'L' or 'O'), the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of +C this array contains the (current) upper triangular factor +C R from the QR factorization of the concatenated block +C Hankel matrices. The diagonal elements of R are positive +C when the Cholesky algorithm was successfully used. +C On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this +C array contains the current upper triangular part of the +C correlation matrix in sequential data processing. +C If ALG = 'F' and BATCH = 'F' or 'I', the array R is not +C referenced. +C On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or +C 'L', the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper +C triangular part of this array must contain the upper +C triangular matrix R computed at the previous call of this +C routine in sequential data processing. The array R need +C not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= 2*(M+L)*NOBR. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= M+L, if ALG = 'F'; +C LIWORK >= 0, if ALG = 'C' or 'Q'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C Let +C k = 0, if CONCT = 'N' and ALG = 'C' or 'Q'; +C k = 2*NOBR-1, if CONCT = 'C' and ALG = 'C' or 'Q'; +C k = 2*NOBR*(M+L+1), if CONCT = 'N' and ALG = 'F'; +C k = 2*NOBR*(M+L+2), if CONCT = 'C' and ALG = 'F'. +C The first (M+L)*k elements of DWORK should be preserved +C during successive calls of the routine with BATCH = 'F' +C or 'I', till the final call with BATCH = 'L'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH <> 'O' and +C CONCT = 'C'; +C LDWORK >= 1, if ALG = 'C', BATCH = 'O' or +C CONCT = 'N'; +C LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F', +C BATCH <> 'O' and CONCT = 'C'; +C LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F', +C BATCH = 'F', 'I' and CONCT = 'N'; +C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F', +C BATCH = 'L' and CONCT = 'N', or +C BATCH = 'O'; +C LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', +C and LDR >= NS = NSMP - 2*NOBR + 1; +C LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O', +C and LDR < NS, or BATCH = 'I' or +C 'L' and CONCT = 'N'; +C LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I' +C or 'L' and CONCT = 'C'. +C The workspace used for ALG = 'Q' is +C LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, +C where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended +C value LDRWRK = NS, assuming a large enough cache size. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the number of 100 cycles in sequential data +C processing has been exhausted without signaling +C that the last block of data was get; the cycle +C counter was reinitialized; +C = 2: a fast algorithm was requested (ALG = 'C' or 'F'), +C but it failed, and the QR algorithm was then used +C (non-sequential data processing). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: a fast algorithm was requested (ALG = 'C', or 'F') +C in sequential data processing, but it failed. The +C routine can be repeatedly called again using the +C standard QR algorithm. +C +C METHOD +C +C 1) For non-sequential data processing using QR algorithm, a +C t x 2(m+l)s matrix H is constructed, where +C +C H = [ Uf' Up' Y' ], for METH = 'M', +C s+1,2s,t 1,s,t 1,2s,t +C +C H = [ U' Y' ], for METH = 'N', +C 1,2s,t 1,2s,t +C +C and Up , Uf , U , and Y are block Hankel +C 1,s,t s+1,2s,t 1,2s,t 1,2s,t +C matrices defined in terms of the input and output data [3]. +C A QR factorization is used to compress the data. +C The fast QR algorithm uses a QR factorization which exploits +C the block-Hankel structure. Actually, the Cholesky factor of H'*H +C is computed. +C +C 2) For sequential data processing using QR algorithm, the QR +C decomposition is done sequentially, by updating the upper +C triangular factor R. This is also performed internally if the +C workspace is not large enough to accommodate an entire batch. +C +C 3) For non-sequential or sequential data processing using +C Cholesky algorithm, the correlation matrix of input-output data is +C computed (sequentially, if requested), taking advantage of the +C block Hankel structure [7]. Then, the Cholesky factor of the +C correlation matrix is found, if possible. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Verhaegen M. +C Subspace Model Identification. Part 3: Analysis of the +C ordinary output-error state-space model identification +C algorithm. +C Int. J. Control, 58, pp. 555-586, 1993. +C +C [3] Verhaegen M. +C Identification of the deterministic part of MIMO state space +C models given in innovations form from input-output data. +C Automatica, Vol.30, No.1, pp.61-74, 1994. +C +C [4] Van Overschee, P., and De Moor, B. +C N4SID: Subspace Algorithms for the Identification of +C Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [5] Peternell, K., Scherrer, W. and Deistler, M. +C Statistical Analysis of Novel Subspace Identification Methods. +C Signal Processing, 52, pp. 161-177, 1996. +C +C [6] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C [7] Sima, V. +C Cholesky or QR Factorization for Data Compression in +C Subspace-based Identification ? +C Proceedings of the Second NICONET Workshop on ``Numerical +C Control Software: SLICOT, a Useful Tool in Industry'', +C December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable (when QR algorithm is +C used), reliable and efficient. The fast Cholesky or QR algorithms +C are more efficient, but the accuracy could diminish by forming the +C correlation matrix. +C 2 +C The QR algorithm needs 0(t(2(m+l)s) ) floating point operations. +C 2 3 +C The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating +C point operations. +C 2 3 2 +C The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating +C point operations. +C +C FURTHER COMMENTS +C +C For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the +C calculations could be rather inefficient if only minimal workspace +C (see argument LDWORK) is provided. It is advisable to provide as +C much workspace as possible. Almost optimal efficiency can be +C obtained for LDWORK = (NS+2)*(2*(M+L)*NOBR), assuming that the +C cache size is large enough to accommodate R, U, Y, and DWORK. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C Feb. 2000, Aug. 2000, Feb. 2004. +C +C KEYWORDS +C +C Cholesky decomposition, Hankel matrix, identification methods, +C multivariable systems, QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + INTEGER MAXCYC + PARAMETER ( MAXCYC = 100 ) +C .. Scalar Arguments .. + INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, + $ NSMP + CHARACTER ALG, BATCH, CONCT, METH +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) +C .. Local Scalars .. + DOUBLE PRECISION UPD, TEMP + INTEGER I, ICOL, ICYCLE, ID, IERR, II, INICYC, INIT, + $ INITI, INU, INY, IREV, ISHFT2, ISHFTU, ISHFTY, + $ ITAU, J, JD, JWORK, LDRWMX, LDRWRK, LLDRW, + $ LMNOBR, LNOBR, MAXWRK, MINWRK, MLDRW, MMNOBR, + $ MNOBR, NCYCLE, NICYCL, NOBR2, NOBR21, NOBRM1, + $ NR, NS, NSF, NSL, NSLAST, NSMPSM + LOGICAL CHALG, CONNEC, FIRST, FQRALG, INTERM, LAST, + $ LINR, MOESP, N4SID, ONEBCH, QRALG +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEQRF, DGER, DLACPY, + $ DLASET, DPOTRF, DSWAP, DSYRK, IB01MY, MB04OD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Save Statement .. +C ICYCLE is used to count the cycles for BATCH = 'I'. It is +C reinitialized at each MAXCYC cycles. +C MAXWRK is used to store the optimal workspace. +C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. + SAVE ICYCLE, MAXWRK, NSMPSM +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + FQRALG = LSAME( ALG, 'F' ) + QRALG = LSAME( ALG, 'Q' ) + CHALG = LSAME( ALG, 'C' ) + ONEBCH = LSAME( BATCH, 'O' ) + FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH + INTERM = LSAME( BATCH, 'I' ) + LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH + IF( .NOT.ONEBCH ) THEN + CONNEC = LSAME( CONCT, 'C' ) + ELSE + CONNEC = .FALSE. + END IF +C + MNOBR = M*NOBR + LNOBR = L*NOBR + LMNOBR = LNOBR + MNOBR + MMNOBR = MNOBR + MNOBR + NOBRM1 = NOBR - 1 + NOBR21 = NOBR + NOBRM1 + NOBR2 = NOBR21 + 1 + IWARN = 0 + INFO = 0 + IERR = 0 + IF( FIRST ) THEN + ICYCLE = 1 + MAXWRK = 1 + NSMPSM = 0 + END IF + NSMPSM = NSMPSM + NSMP + NR = LMNOBR + LMNOBR +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN + INFO = -3 + ELSE IF( .NOT. ONEBCH ) THEN + IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) + $ INFO = -4 + END IF + IF( INFO.EQ.0 ) THEN + IF( NOBR.LE.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( L.LE.0 ) THEN + INFO = -7 + ELSE IF( NSMP.LT.NOBR2 .OR. + $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN + INFO = -8 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -10 + ELSE IF( LDY.LT.NSMP ) THEN + INFO = -12 + ELSE IF( LDR.LT.NR ) THEN + INFO = -14 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe +C the minimal amount of workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + NS = NSMP - NOBR21 + IF ( CHALG ) THEN + IF ( .NOT.ONEBCH .AND. CONNEC ) THEN + MINWRK = 2*( NR - M - L ) + ELSE + MINWRK = 1 + END IF + ELSE IF ( FQRALG ) THEN + IF ( .NOT.ONEBCH .AND. CONNEC ) THEN + MINWRK = NR*( M + L + 3 ) + ELSE IF ( FIRST .OR. INTERM ) THEN + MINWRK = NR*( M + L + 1 ) + ELSE + MINWRK = 2*NR*( M + L + 1 ) + NR + END IF + ELSE + MINWRK = 2*NR + MAXWRK = NR + NR*ILAENV( 1, 'DGEQRF', ' ', NS, NR, -1, + $ -1 ) + IF ( FIRST ) THEN + IF ( LDR.LT.NS ) THEN + MINWRK = MINWRK + NR + MAXWRK = NS*NR + MAXWRK + END IF + ELSE + IF ( CONNEC ) THEN + MINWRK = MINWRK*( NOBR + 1 ) + ELSE + MINWRK = MINWRK + NR + END IF + MAXWRK = NS*NR + MAXWRK + END IF + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -17 + DWORK( 1 ) = MINWRK + END IF + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01MD', -INFO ) + RETURN + END IF +C + IF ( CHALG ) THEN +C +C Compute the R factor from a Cholesky factorization of the +C input-output data correlation matrix. +C +C Set the parameters for constructing the correlations of the +C current block. +C + LDRWRK = 2*NOBR2 - 2 + IF( FIRST ) THEN + UPD = ZERO + ELSE + UPD = ONE + END IF +C + IF( .NOT.FIRST .AND. CONNEC ) THEN +C +C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of +C U and Y into their appropriate position in sequential +C processing. The process is performed column-wise, in +C reverse order, first for Y and then for U. +C Workspace: need (4*NOBR-2)*(M+L). +C + IREV = NR - M - L - NOBR21 + 1 + ICOL = 2*( NR - M - L ) - LDRWRK + 1 +C + DO 10 J = 2, M + L + DO 5 I = NOBR21 - 1, 0, -1 + DWORK(ICOL+I) = DWORK(IREV+I) + 5 CONTINUE + IREV = IREV - NOBR21 + ICOL = ICOL - LDRWRK + 10 CONTINUE +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR21, M, U, LDU, DWORK(NOBR2), + $ LDRWRK ) + CALL DLACPY( 'Full', NOBR21, L, Y, LDY, + $ DWORK(LDRWRK*M+NOBR2), LDRWRK ) + END IF +C + IF ( M.GT.0 ) THEN +C +C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + +C ... + u_(i+NS-1)*u_(j+NS-1)', +C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, +C NS = NSMP - 2s + 1, and Guu0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed +C till the current block for BATCH = 'I' or 'L'. The matrix +C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The +C upper triangle of the U-U correlations, Guu, is computed +C (or updated) column-wise in the array R, that is, in the +C order Guu(1,1), Guu(1,2), Guu(2,2), ..., Guu(2s,2s). +C Only the submatrices of the first block-row are fully +C computed (or updated). The remaining ones are determined +C exploiting the block-Hankel structure, using the updating +C formula +C +C Guu(i+1,j+1) = Guu0(i+1,j+1) - Guu0(i,j) + Guu(i,j) + +C u_(i+NS)*u_(j+NS)' - u_i*u_j'. +C + IF( .NOT.FIRST ) THEN +C +C Subtract the contribution of the previous block of data +C in sequential processing. The columns must be processed +C in backward order. +C + DO 20 I = NOBR21*M, 1, -1 + CALL DAXPY( I, -ONE, R(1,I), 1, R(M+1,M+I), 1 ) + 20 CONTINUE +C + END IF +C +C Compute/update Guu(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR21, ONE, DWORK, + $ LDRWRK, UPD, R, LDR ) + CALL DSYRK( 'Upper', 'Transpose', M, NS, ONE, U, LDU, UPD, + $ R, LDR ) +C + JD = 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 70 J = 2, NOBR2 + JD = JD + M + ID = M + 1 +C +C Compute/update Guu(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, + $ U, LDU, U(J,1), LDU, UPD, R(1,JD), LDR ) +C +C Compute/update Guu(2:j,j), exploiting the +C block-Hankel structure. +C + IF( FIRST ) THEN +C + DO 30 I = JD - M, JD - 1 + CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) + 30 CONTINUE +C + ELSE +C + DO 40 I = JD - M, JD - 1 + CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) + 40 CONTINUE +C + END IF +C + DO 50 I = 2, J - 1 + CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, + $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) + CALL DGER( M, M, -ONE, U(I-1,1), LDU, U(J-1,1), + $ LDU, R(ID,JD), LDR ) + ID = ID + M + 50 CONTINUE +C + DO 60 I = 1, M + CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, + $ R(JD,JD+I-1), 1 ) + CALL DAXPY( I, -U(J-1,I), U(J-1,1), LDU, + $ R(JD,JD+I-1), 1 ) + 60 CONTINUE +C + 70 CONTINUE +C + ELSE +C + DO 120 J = 2, NOBR2 + JD = JD + M + ID = M + 1 +C +C Compute/update Guu(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR21, + $ ONE, DWORK, LDRWRK, DWORK(J), LDRWRK, UPD, + $ R(1,JD), LDR ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE, + $ U, LDU, U(J,1), LDU, ONE, R(1,JD), LDR ) +C +C Compute/update Guu(2:j,j) for sequential processing +C with connected blocks, exploiting the block-Hankel +C structure. +C + IF( FIRST ) THEN +C + DO 80 I = JD - M, JD - 1 + CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 ) + 80 CONTINUE +C + ELSE +C + DO 90 I = JD - M, JD - 1 + CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 ) + 90 CONTINUE +C + END IF +C + DO 100 I = 2, J - 1 + CALL DGER( M, M, ONE, U(NS+I-1,1), LDU, + $ U(NS+J-1,1), LDU, R(ID,JD), LDR ) + CALL DGER( M, M, -ONE, DWORK(I-1), LDRWRK, + $ DWORK(J-1), LDRWRK, R(ID,JD), LDR ) + ID = ID + M + 100 CONTINUE +C + DO 110 I = 1, M + CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU, + $ R(JD,JD+I-1), 1 ) + CALL DAXPY( I, -DWORK((I-1)*LDRWRK+J-1), + $ DWORK(J-1), LDRWRK, R(JD,JD+I-1), 1 ) + 110 CONTINUE +C + 120 CONTINUE +C + END IF +C + IF ( LAST .AND. MOESP ) THEN +C +C Interchange past and future parts for MOESP algorithm. +C (Only the upper triangular parts are interchanged, and +C the (1,2) part is transposed in-situ.) +C + TEMP = R(1,1) + R(1,1) = R(MNOBR+1,MNOBR+1) + R(MNOBR+1,MNOBR+1) = TEMP +C + DO 130 J = 2, MNOBR + CALL DSWAP( J, R(1,J), 1, R(MNOBR+1,MNOBR+J), 1 ) + CALL DSWAP( J-1, R(1,MNOBR+J), 1, R(J,MNOBR+1), LDR ) + 130 CONTINUE +C + END IF +C +C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + +C ... + u_(i+NS-1)*y_(j+NS-1)', +C where u_i' is the i-th row of U, y_j' is the j-th row +C of Y, j = 1 : 2s, i = 1 : 2s, NS = NSMP - 2s + 1, and +C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it +C is the matrix Guy(i,j) computed till the current block for +C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The U-Y +C correlations, Guy, are computed (or updated) column-wise +C in the array R. Only the submatrices of the first block- +C column and block-row are fully computed (or updated). The +C remaining ones are determined exploiting the block-Hankel +C structure, using the updating formula +C +C Guy(i+1,j+1) = Guy0(i+1,j+1) - Guy0(i,j) + Guy(i,j) + +C u_(i+NS)*y(j+NS)' - u_i*y_j'. +C + II = MMNOBR - M + IF( .NOT.FIRST ) THEN +C +C Subtract the contribution of the previous block of data +C in sequential processing. The columns must be processed +C in backward order. +C + DO 140 I = NR - L, MMNOBR + 1, -1 + CALL DAXPY( II, -ONE, R(1,I), 1, R(M+1,L+I), 1 ) + 140 CONTINUE +C + END IF +C +C Compute/update the first block-column of Guy, Guy(i,1). +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 150 I = 1, NOBR2 + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, + $ U(I,1), LDU, Y, LDY, UPD, + $ R((I-1)*M+1,MMNOBR+1), LDR ) + 150 CONTINUE +C + ELSE +C + DO 160 I = 1, NOBR2 + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, + $ ONE, DWORK(I), LDRWRK, DWORK(LDRWRK*M+1), + $ LDRWRK, UPD, R((I-1)*M+1,MMNOBR+1), LDR ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, + $ U(I,1), LDU, Y, LDY, ONE, + $ R((I-1)*M+1,MMNOBR+1), LDR ) + 160 CONTINUE +C + END IF +C + JD = MMNOBR + 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 200 J = 2, NOBR2 + JD = JD + L + ID = M + 1 +C +C Compute/update Guy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, + $ U, LDU, Y(J,1), LDY, UPD, R(1,JD), LDR ) +C +C Compute/update Guy(2:2*s,j), exploiting the +C block-Hankel structure. +C + IF( FIRST ) THEN +C + DO 170 I = JD - L, JD - 1 + CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) + 170 CONTINUE +C + ELSE +C + DO 180 I = JD - L, JD - 1 + CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) + 180 CONTINUE +C + END IF +C + DO 190 I = 2, NOBR2 + CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, + $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) + CALL DGER( M, L, -ONE, U(I-1,1), LDU, Y(J-1,1), + $ LDY, R(ID,JD), LDR ) + ID = ID + M + 190 CONTINUE +C + 200 CONTINUE +C + ELSE +C + DO 240 J = 2, NOBR2 + JD = JD + L + ID = M + 1 +C +C Compute/update Guy(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21, + $ ONE, DWORK, LDRWRK, DWORK(LDRWRK*M+J), + $ LDRWRK, UPD, R(1,JD), LDR ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE, + $ U, LDU, Y(J,1), LDY, ONE, R(1,JD), LDR ) +C +C Compute/update Guy(2:2*s,j) for sequential +C processing with connected blocks, exploiting the +C block-Hankel structure. +C + IF( FIRST ) THEN +C + DO 210 I = JD - L, JD - 1 + CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 ) + 210 CONTINUE +C + ELSE +C + DO 220 I = JD - L, JD - 1 + CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 ) + 220 CONTINUE +C + END IF +C + DO 230 I = 2, NOBR2 + CALL DGER( M, L, ONE, U(NS+I-1,1), LDU, + $ Y(NS+J-1,1), LDY, R(ID,JD), LDR ) + CALL DGER( M, L, -ONE, DWORK(I-1), LDRWRK, + $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), + $ LDR ) + ID = ID + M + 230 CONTINUE +C + 240 CONTINUE +C + END IF +C + IF ( LAST .AND. MOESP ) THEN +C +C Interchange past and future parts of U-Y correlations +C for MOESP algorithm. +C + DO 250 J = MMNOBR + 1, NR + CALL DSWAP( MNOBR, R(1,J), 1, R(MNOBR+1,J), 1 ) + 250 CONTINUE +C + END IF + END IF +C +C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + +C y_(i+NS-1)*y_(i+NS-1)', +C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, +C NS = NSMP - 2s + 1, and Gyy0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till +C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, +C and Gyy(j,j) is symmetric. The upper triangle of the Y-Y +C correlations, Gyy, is computed (or updated) column-wise in +C the corresponding part of the array R, that is, in the order +C Gyy(1,1), Gyy(1,2), Gyy(2,2), ..., Gyy(2s,2s). Only the +C submatrices of the first block-row are fully computed (or +C updated). The remaining ones are determined exploiting the +C block-Hankel structure, using the updating formula +C +C Gyy(i+1,j+1) = Gyy0(i+1,j+1) - Gyy0(i,j) + Gyy(i,j) + +C y_(i+NS)*y_(j+NS)' - y_i*y_j'. +C + JD = MMNOBR + 1 +C + IF( .NOT.FIRST ) THEN +C +C Subtract the contribution of the previous block of data +C in sequential processing. The columns must be processed in +C backward order. +C + DO 260 I = NR - L, MMNOBR + 1, -1 + CALL DAXPY( I-MMNOBR, -ONE, R(JD,I), 1, R(JD+L,L+I), 1 ) + 260 CONTINUE +C + END IF +C +C Compute/update Gyy(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR21, ONE, + $ DWORK(LDRWRK*M+1), LDRWRK, UPD, R(JD,JD), LDR ) + CALL DSYRK( 'Upper', 'Transpose', L, NS, ONE, Y, LDY, UPD, + $ R(JD,JD), LDR ) +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 310 J = 2, NOBR2 + JD = JD + L + ID = MMNOBR + L + 1 +C +C Compute/update Gyy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, + $ LDY, Y(J,1), LDY, UPD, R(MMNOBR+1,JD), LDR ) +C +C Compute/update Gyy(2:j,j), exploiting the block-Hankel +C structure. +C + IF( FIRST ) THEN +C + DO 270 I = JD - L, JD - 1 + CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, + $ R(MMNOBR+L+1,L+I), 1 ) + 270 CONTINUE +C + ELSE +C + DO 280 I = JD - L, JD - 1 + CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, + $ R(MMNOBR+L+1,L+I), 1 ) + 280 CONTINUE +C + END IF +C + DO 290 I = 2, J - 1 + CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), + $ LDY, R(ID,JD), LDR ) + CALL DGER( L, L, -ONE, Y(I-1,1), LDY, Y(J-1,1), LDY, + $ R(ID,JD), LDR ) + ID = ID + L + 290 CONTINUE +C + DO 300 I = 1, L + CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, + $ R(JD,JD+I-1), 1 ) + CALL DAXPY( I, -Y(J-1,I), Y(J-1,1), LDY, R(JD,JD+I-1), + $ 1 ) + 300 CONTINUE +C + 310 CONTINUE +C + ELSE +C + DO 360 J = 2, NOBR2 + JD = JD + L + ID = MMNOBR + L + 1 +C +C Compute/update Gyy(1,j) for sequential processing with +C connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR21, + $ ONE, DWORK(LDRWRK*M+1), LDRWRK, + $ DWORK(LDRWRK*M+J), LDRWRK, UPD, + $ R(MMNOBR+1,JD), LDR ) + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y, + $ LDY, Y(J,1), LDY, ONE, R(MMNOBR+1,JD), LDR ) +C +C Compute/update Gyy(2:j,j) for sequential processing +C with connected blocks, exploiting the block-Hankel +C structure. +C + IF( FIRST ) THEN +C + DO 320 I = JD - L, JD - 1 + CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1, + $ R(MMNOBR+L+1,L+I), 1 ) + 320 CONTINUE +C + ELSE +C + DO 330 I = JD - L, JD - 1 + CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1, + $ R(MMNOBR+L+1,L+I), 1 ) + 330 CONTINUE +C + END IF +C + DO 340 I = 2, J - 1 + CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1), + $ LDY, R(ID,JD), LDR ) + CALL DGER( L, L, -ONE, DWORK(LDRWRK*M+I-1), LDRWRK, + $ DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD), + $ LDR ) + ID = ID + L + 340 CONTINUE +C + DO 350 I = 1, L + CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY, + $ R(JD,JD+I-1), 1 ) + CALL DAXPY( I, -DWORK(LDRWRK*(M+I-1)+J-1), + $ DWORK(LDRWRK*M+J-1), LDRWRK, R(JD,JD+I-1), + $ 1 ) + 350 CONTINUE +C + 360 CONTINUE +C + END IF +C + IF ( .NOT.LAST ) THEN + IF ( CONNEC ) THEN +C +C For sequential processing with connected data blocks, +C save the remaining ("connection") elements of U and Y +C in the first (M+L)*(2*NOBR-1) locations of DWORK. +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR21, M, U(NS+1,1), LDU, DWORK, + $ NOBR21 ) + CALL DLACPY( 'Full', NOBR21, L, Y(NS+1,1), LDY, + $ DWORK(MMNOBR-M+1), NOBR21 ) + END IF +C +C Return to get new data. +C + ICYCLE = ICYCLE + 1 + IF ( ICYCLE.GT.MAXCYC ) + $ IWARN = 1 + RETURN +C + ELSE +C +C Try to compute the Cholesky factor of the correlation +C matrix. +C + CALL DPOTRF( 'Upper', NR, R, LDR, IERR ) + GO TO 370 + END IF + ELSE IF ( FQRALG ) THEN +C +C Compute the R factor from a fast QR factorization of the +C input-output data correlation matrix. +C + CALL IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, + $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, + $ IERR ) + IF( .NOT.LAST ) + $ RETURN + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + 370 CONTINUE +C + IF( IERR.NE.0 ) THEN +C +C Error return from a fast factorization algorithm of the +C input-output data correlation matrix. +C + IF( ONEBCH ) THEN + QRALG = .TRUE. + IWARN = 2 + MINWRK = 2*NR + MAXWRK = NR + NR*ILAENV( 1, 'DGEQRF', ' ', NS, NR, -1, + $ -1 ) + IF ( LDR.LT.NS ) THEN + MINWRK = MINWRK + NR + MAXWRK = NS*NR + MAXWRK + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -17 +C +C Return: Not enough workspace. +C + DWORK( 1 ) = MINWRK + CALL XERBLA( 'IB01MD', -INFO ) + RETURN + END IF + ELSE + INFO = 1 + RETURN + END IF + END IF +C + IF ( QRALG ) THEN +C +C Compute the R factor from a QR factorization of the matrix H +C of concatenated block Hankel matrices. +C +C Construct the matrix H. +C +C Set the parameters for constructing the current segment of the +C Hankel matrix, taking the available memory space into account. +C INITI+1 points to the beginning rows of U and Y from which +C data are taken when NCYCLE > 1 inner cycles are needed, +C or for sequential processing with connected blocks. +C LDRWMX is the number of rows that can fit in the working space. +C LDRWRK is the actual number of rows processed in this space. +C NSLAST is the number of samples to be processed at the last +C inner cycle. +C + INITI = 0 + LDRWMX = LDWORK / NR - 2 + NCYCLE = 1 + NSLAST = NSMP + LINR = .FALSE. + IF ( FIRST ) THEN + LINR = LDR.GE.NS + LDRWRK = NS + ELSE IF ( CONNEC ) THEN + LDRWRK = NSMP + ELSE + LDRWRK = NS + END IF + INICYC = 1 +C + IF ( .NOT.LINR ) THEN + IF ( LDRWMX.LT.LDRWRK ) THEN +C +C Not enough working space for doing a single inner cycle. +C NCYCLE inner cycles are to be performed for the current +C data block using the working space. +C + NCYCLE = LDRWRK / LDRWMX + NSLAST = MOD( LDRWRK, LDRWMX ) + IF ( NSLAST.NE.0 ) THEN + NCYCLE = NCYCLE + 1 + ELSE + NSLAST = LDRWMX + END IF + LDRWRK = LDRWMX + NS = LDRWRK + IF ( FIRST ) INICYC = 2 + END IF + MLDRW = M*LDRWRK + LLDRW = L*LDRWRK + INU = MLDRW*NOBR + 1 + INY = MLDRW*NOBR2 + 1 + END IF +C +C Process the data given at the current call. +C + IF ( .NOT.FIRST .AND. CONNEC ) THEN +C +C Restore the saved (M+L)*(2*NOBR-1) "connection" elements of +C U and Y into their appropriate position in sequential +C processing. The process is performed column-wise, in +C reverse order, first for Y and then for U. +C + IREV = NR - M - L - NOBR21 + 1 + ICOL = INY + LLDRW - LDRWRK +C + DO 380 J = 1, L + DO 375 I = NOBR21 - 1, 0, -1 + DWORK(ICOL+I) = DWORK(IREV+I) + 375 CONTINUE + IREV = IREV - NOBR21 + ICOL = ICOL - LDRWRK + 380 CONTINUE +C + IF( MOESP ) THEN + ICOL = INU + MLDRW - LDRWRK + ELSE + ICOL = MLDRW - LDRWRK + 1 + END IF +C + DO 390 J = 1, M + DO 385 I = NOBR21 - 1, 0, -1 + DWORK(ICOL+I) = DWORK(IREV+I) + 385 CONTINUE + IREV = IREV - NOBR21 + ICOL = ICOL - LDRWRK + 390 CONTINUE +C + IF( MOESP ) + $ CALL DLACPY( 'Full', NOBRM1, M, DWORK(INU+NOBR), LDRWRK, + $ DWORK, LDRWRK ) + END IF +C +C Data compression using QR factorization. +C + IF ( FIRST ) THEN +C +C Non-sequential data processing or first block in +C sequential data processing: +C Use the general QR factorization algorithm. +C + IF ( LINR ) THEN +C +C Put the input-output data in the array R. +C + IF( M.GT.0 ) THEN + IF( MOESP ) THEN +C + DO 400 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, + $ R(1,M*(I-1)+1), LDR ) + 400 CONTINUE +C + DO 410 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ R(1,MNOBR+M*(I-1)+1), LDR ) + 410 CONTINUE +C + ELSE +C + DO 420 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ R(1,M*(I-1)+1), LDR ) + 420 CONTINUE +C + END IF + END IF +C + DO 430 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, + $ R(1,MMNOBR+L*(I-1)+1), LDR ) + 430 CONTINUE +C +C Workspace: need 4*(M+L)*NOBR, +C prefer 2*(M+L)*NOBR+2*(M+L)*NOBR*NB. +C + ITAU = 1 + JWORK = ITAU + NR + CALL DGEQRF( NS, NR, R, LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + ELSE +C +C Put the input-output data in the array DWORK. +C + IF( M.GT.0 ) THEN + ISHFTU = 1 + IF( MOESP ) THEN + ISHFT2 = INU +C + DO 440 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 440 CONTINUE +C + DO 450 I = 1, NOBR + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 450 CONTINUE +C + ELSE +C + DO 460 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, M, U(I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 460 CONTINUE +C + END IF + END IF +C + ISHFTY = INY +C + DO 470 I = 1, NOBR2 + CALL DLACPY( 'Full', NS, L, Y(I,1), LDY, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 470 CONTINUE +C +C Workspace: need 2*(M+L)*NOBR + 4*(M+L)*NOBR, +C prefer NS*2*(M+L)*NOBR + 2*(M+L)*NOBR +C + 2*(M+L)*NOBR*NB, +C used LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR, +C where NS = NSMP - 2*NOBR + 1, +C LDRWRK = min(NS, LDWORK/(2*(M+L)*NOBR)-2). +C + ITAU = LDRWRK*NR + 1 + JWORK = ITAU + NR + CALL DGEQRF( NS, NR, DWORK, LDRWRK, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + CALL DLACPY( 'Upper ', MIN(NS,NR), NR, DWORK, LDRWRK, R, + $ LDR ) + END IF +C + IF ( NS.LT.NR ) + $ CALL DLASET( 'Upper ', NR - NS, NR - NS, ZERO, ZERO, + $ R(NS+1,NS+1), LDR ) + INITI = INITI + NS + END IF +C + IF ( NCYCLE.GT.1 .OR. .NOT.FIRST ) THEN +C +C Remaining segments of the first data block or +C remaining segments/blocks in sequential data processing: +C Use a structure-exploiting QR factorization algorithm. +C + NSL = LDRWRK + IF ( .NOT.CONNEC ) NSL = NS + ITAU = LDRWRK*NR + 1 + JWORK = ITAU + NR +C + DO 560 NICYCL = INICYC, NCYCLE +C +C INIT denotes the beginning row where new data are put. +C + IF ( CONNEC .AND. NICYCL.EQ.1 ) THEN + INIT = NOBR2 + ELSE + INIT = 1 + END IF + IF ( NCYCLE.GT.1 .AND. NICYCL.EQ.NCYCLE ) THEN +C +C Last samples in the last data segment of a block. +C + NS = NSLAST + NSL = NSLAST + END IF +C +C Put the input-output data in the array DWORK. +C + NSF = NS + IF ( INIT.GT.1 .AND. NCYCLE.GT.1 ) NSF = NSF - NOBR21 + IF ( M.GT.0 ) THEN + ISHFTU = INIT +C + IF( MOESP ) THEN + ISHFT2 = INIT + INU - 1 +C + DO 480 I = 1, NOBR + CALL DLACPY( 'Full', NSF, M, U(INITI+NOBR+I,1), + $ LDU, DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 480 CONTINUE +C + DO 490 I = 1, NOBR + CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 490 CONTINUE +C + ELSE +C + DO 500 I = 1, NOBR2 + CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 500 CONTINUE +C + END IF + END IF +C + ISHFTY = INIT + INY - 1 +C + DO 510 I = 1, NOBR2 + CALL DLACPY( 'Full', NSF, L, Y(INITI+I,1), LDY, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 510 CONTINUE +C + IF ( INIT.GT.1 ) THEN +C +C Prepare the connection to the previous block of data +C in sequential processing. +C + IF( MOESP .AND. M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR, M, U, LDU, DWORK(NOBR), + $ LDRWRK ) +C +C Shift the elements from the connection to the previous +C block of data in sequential processing. +C + IF ( M.GT.0 ) THEN + ISHFTU = MLDRW + 1 +C + IF( MOESP ) THEN + ISHFT2 = MLDRW + INU +C + DO 520 I = 1, NOBRM1 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFTU-MLDRW+1), LDRWRK, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 520 CONTINUE +C + DO 530 I = 1, NOBRM1 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFT2-MLDRW+1), LDRWRK, + $ DWORK(ISHFT2), LDRWRK ) + ISHFT2 = ISHFT2 + MLDRW + 530 CONTINUE +C + ELSE +C + DO 540 I = 1, NOBR21 + CALL DLACPY( 'Full', NOBR21, M, + $ DWORK(ISHFTU-MLDRW+1), LDRWRK, + $ DWORK(ISHFTU), LDRWRK ) + ISHFTU = ISHFTU + MLDRW + 540 CONTINUE +C + END IF + END IF +C + ISHFTY = LLDRW + INY +C + DO 550 I = 1, NOBR21 + CALL DLACPY( 'Full', NOBR21, L, + $ DWORK(ISHFTY-LLDRW+1), LDRWRK, + $ DWORK(ISHFTY), LDRWRK ) + ISHFTY = ISHFTY + LLDRW + 550 CONTINUE +C + END IF +C +C Workspace: need LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR. +C + CALL MB04OD( 'Full', NR, 0, NSL, R, LDR, DWORK, LDRWRK, + $ DUM, NR, DUM, NR, DWORK(ITAU), DWORK(JWORK) + $ ) + INITI = INITI + NSF + 560 CONTINUE +C + END IF +C + IF ( .NOT.LAST ) THEN + IF ( CONNEC ) THEN +C +C For sequential processing with connected data blocks, +C save the remaining ("connection") elements of U and Y +C in the first (M+L)*(2*NOBR-1) locations of DWORK. +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR21, M, U(INITI+1,1), LDU, + $ DWORK, NOBR21 ) + CALL DLACPY( 'Full', NOBR21, L, Y(INITI+1,1), LDY, + $ DWORK(MMNOBR-M+1), NOBR21 ) + END IF +C +C Return to get new data. +C + ICYCLE = ICYCLE + 1 + IF ( ICYCLE.LE.MAXCYC ) + $ RETURN + IWARN = 1 + ICYCLE = 1 +C + END IF +C + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAXWRK + IF ( LAST ) THEN + ICYCLE = 1 + MAXWRK = 1 + NSMPSM = 0 + END IF + RETURN +C +C *** Last line of IB01MD *** + END diff --git a/mex/sources/libslicot/IB01MY.f b/mex/sources/libslicot/IB01MY.f new file mode 100644 index 000000000..a76f452a3 --- /dev/null +++ b/mex/sources/libslicot/IB01MY.f @@ -0,0 +1,1094 @@ + SUBROUTINE IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, + $ Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct an upper triangular factor R of the concatenated +C block Hankel matrices using input-output data, via a fast QR +C algorithm based on displacement rank. The input-output data can, +C optionally, be processed sequentially. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C BATCH CHARACTER*1 +C Specifies whether or not sequential data processing is to +C be used, and, for sequential processing, whether or not +C the current data block is the first block, an intermediate +C block, or the last block, as follows: +C = 'F': the first block in sequential data processing; +C = 'I': an intermediate block in sequential data +C processing; +C = 'L': the last block in sequential data processing; +C = 'O': one block only (non-sequential data processing). +C NOTE that when 100 cycles of sequential data processing +C are completed for BATCH = 'I', a warning is +C issued, to prevent for an infinite loop. +C +C CONCT CHARACTER*1 +C Specifies whether or not the successive data blocks in +C sequential data processing belong to a single experiment, +C as follows: +C = 'C': the current data block is a continuation of the +C previous data block and/or it will be continued +C by the next data block; +C = 'N': there is no connection between the current data +C block and the previous and/or the next ones. +C This parameter is not used if BATCH = 'O'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C block Hankel matrices to be processed. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, the +C estimated dimension of state vector.) +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C When M = 0, no system inputs are processed. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). (When sequential data processing is used, +C NSMP is the number of samples of the current data +C block.) +C NSMP >= 2*(M+L+1)*NOBR - 1, for non-sequential +C processing; +C NSMP >= 2*NOBR, for sequential processing. +C The total number of samples when calling the routine with +C BATCH = 'L' should be at least 2*(M+L+1)*NOBR - 1. +C The NSMP argument may vary from a cycle to another in +C sequential data processing, but NOBR, M, and L should +C be kept constant. For efficiency, it is advisable to use +C NSMP as large as possible. +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NSMP-by-M part of this array must contain the +C t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= NSMP, if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= NSMP. +C +C R (output) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C If INFO = 0 and BATCH = 'L' or 'O', the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this +C array contains the upper triangular factor R from the +C QR factorization of the concatenated block Hankel +C matrices. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= 2*(M+L)*NOBR. +C +C Workspace +C +C IWORK INTEGER array, dimension (M+L) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C The first (M+L)*2*NOBR*(M+L+c) elements of DWORK should +C be preserved during successive calls of the routine +C with BATCH = 'F' or 'I', till the final call with +C BATCH = 'L', where +C c = 1, if the successive data blocks do not belong to a +C single experiment (CONCT = 'N'); +C c = 2, if the successive data blocks belong to a single +C experiment (CONCT = 'C'). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= (M+L)*2*NOBR*(M+L+3), +C if BATCH <> 'O' and CONCT = 'C'; +C LDWORK >= (M+L)*2*NOBR*(M+L+1), +C if BATCH = 'F' or 'I' and CONCT = 'N'; +C LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, +C if BATCH = 'L' and CONCT = 'N', +C or BATCH = 'O'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the number of 100 cycles in sequential data +C processing has been exhausted without signaling +C that the last block of data was get. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the fast QR factorization algorithm failed. The +C matrix H'*H is not (numerically) positive definite. +C +C METHOD +C +C Consider the t x 2(m+l)s matrix H of concatenated block Hankel +C matrices +C +C H = [ Uf' Up' Y' ], for METH = 'M', +C s+1,2s,t 1,s,t 1,2s,t +C +C H = [ U' Y' ], for METH = 'N', +C 1,2s,t 1,2s,t +C +C where Up , Uf , U , and Y are block +C 1,s,t s+1,2s,t 1,2s,t 1,2s,t +C Hankel matrices defined in terms of the input and output data [3]. +C The fast QR algorithm uses a factorization of H'*H which exploits +C the block-Hankel structure, via a displacement rank technique [5]. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Verhaegen M. +C Subspace Model Identification. Part 3: Analysis of the +C ordinary output-error state-space model identification +C algorithm. +C Int. J. Control, 58, pp. 555-586, 1993. +C +C [3] Verhaegen M. +C Identification of the deterministic part of MIMO state space +C models given in innovations form from input-output data. +C Automatica, Vol.30, No.1, pp.61-74, 1994. +C +C [4] Van Overschee, P., and De Moor, B. +C N4SID: Subspace Algorithms for the Identification of +C Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [5] Kressner, D., Mastronardi, N., Sima, V., Van Dooren, P., and +C Van Huffel, S. +C A Fast Algorithm for Subspace State-space System +C Identification via Exploitation of the Displacement Structure. +C J. Comput. Appl. Math., Vol.132, No.1, pp. 71-81, 2001. +C +C NUMERICAL ASPECTS +C +C The implemented method is reliable and efficient. Numerical +C difficulties are possible when the matrix H'*H is nearly rank +C defficient. The method cannot be used if the matrix H'*H is not +C numerically positive definite. +C 2 3 2 +C The algorithm requires 0(2t(m+l) s)+0(4(m+l) s ) floating point +C operations. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Universiteit Leuven, June 2000. +C Partly based on Matlab codes developed by N. Mastronardi, +C Katholieke Universiteit Leuven, February 2000. +C +C REVISIONS +C +C V. Sima, July 2000, August 2000, Feb. 2004, May 2009. +C +C KEYWORDS +C +C Displacement rank, Hankel matrix, Householder transformation, +C identification methods, multivariable systems. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + INTEGER MAXCYC + PARAMETER ( MAXCYC = 100 ) +C .. Scalar Arguments .. + INTEGER INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR, + $ NSMP + CHARACTER BATCH, CONCT, METH +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *) +C .. Local Scalars .. + DOUBLE PRECISION BETA, CS, SN, UPD, TAU + INTEGER I, ICJ, ICOL, ICONN, ICYCLE, IERR, IMAX, ING, + $ INGC, INGP, IPG, IPGC, IPY, IREV, ITAU, J, JD, + $ JDS, JWORK, K, LDRWRK, LLNOBR, LNOBR, LNRG, + $ MAXWRK, MINWRK, MMNOBR, MNOBR, MNRG, NOBR2, + $ NOBR21, NR, NRG, NS, NSM, NSMPSM + LOGICAL CONNEC, FIRST, INTERM, LAST, MOESP, N4SID, + $ ONEBCH +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLARF, DLARFG, + $ DLASET, DORMQR, DSCAL, DSWAP, DSYRK, MA02ED, + $ MA02FD, MB04ID, MB04OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, SQRT +C .. Save Statement .. +C ICYCLE is used to count the cycles for BATCH = 'I'. +C MAXWRK is used to store the optimal workspace. +C NSMPSM is used to sum up the NSMP values for BATCH <> 'O'. + SAVE ICYCLE, MAXWRK, NSMPSM +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + ONEBCH = LSAME( BATCH, 'O' ) + FIRST = LSAME( BATCH, 'F' ) .OR. ONEBCH + INTERM = LSAME( BATCH, 'I' ) + LAST = LSAME( BATCH, 'L' ) .OR. ONEBCH + IF( .NOT.ONEBCH ) THEN + CONNEC = LSAME( CONCT, 'C' ) + ELSE + CONNEC = .FALSE. + END IF + MNOBR = M*NOBR + LNOBR = L*NOBR + MMNOBR = MNOBR + MNOBR + LLNOBR = LNOBR + LNOBR + NOBR2 = 2*NOBR + NOBR21 = NOBR2 - 1 + IWARN = 0 + INFO = 0 + IF( FIRST ) THEN + ICYCLE = 1 + MAXWRK = 1 + NSMPSM = 0 + END IF + NSMPSM = NSMPSM + NSMP + NR = MMNOBR + LLNOBR +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN + INFO = -2 + ELSE IF( .NOT. ONEBCH ) THEN + IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) ) + $ INFO = -3 + END IF + IF( INFO.EQ.0 ) THEN + IF( NOBR.LE.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LE.0 ) THEN + INFO = -6 + ELSE IF( NSMP.LT.NOBR2 .OR. + $ ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -9 + ELSE IF( LDY.LT.NSMP ) THEN + INFO = -11 + ELSE IF( LDR.LT.NR ) THEN + INFO = -13 + ELSE +C +C Compute workspace. +C NRG is the number of positive (or negative) generators. +C + NRG = M + L + 1 + IF ( .NOT.ONEBCH .AND. CONNEC ) THEN + MINWRK = NR*( NRG + 2 ) + ELSE IF ( FIRST .OR. INTERM ) THEN + MINWRK = NR*NRG + ELSE + MINWRK = 2*NR*NRG + NR + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) +C + IF( LDWORK.LT.MINWRK ) + $ INFO = -16 + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + NSMPSM = 0 + IF ( INFO.EQ.-16 ) + $ DWORK( 1 ) = MINWRK + CALL XERBLA( 'IB01MY', -INFO ) + RETURN + END IF +C +C Compute the R factor from a fast QR factorization of the +C matrix H, a concatenation of two block Hankel matrices. +C Specifically, a displacement rank technique is applied to +C the block Toeplitz matrix, G = (P*H)'*(P*H), where P is a +C 2-by-2 block diagonal matrix, having as diagonal blocks identity +C matrices with columns taken in the reverse order. +C The technique builds and processes the generators of G. The +C matrices G and G1 = H'*H have the same R factor. +C +C Set the parameters for constructing the correlations of the +C current block. +C NSM is the number of processed samples in U and Y, t - 2s. +C IPG and ING are pointers to the "positive" and "negative" +C generators, stored row-wise in the workspace. All "positive" +C generators are stored before any "negative" generators. +C If BATCH <> 'O' and CONCT = 'C', the "connection" elements of +C two successive batches are stored in the same workspace as the +C "negative" generators (which will be computed later on). +C IPY is a pointer to the Y part of the "positive" generators. +C LDRWRK is used as a leading dimension for the workspace part used +C to store the "connection" elements. +C + NS = NSMP - NOBR21 + NSM = NS - 1 + MNRG = M*NRG + LNRG = L*NRG +C + LDRWRK = 2*NOBR2 + IF( FIRST ) THEN + UPD = ZERO + ELSE + UPD = ONE + END IF + DUM(1) = ZERO +C + IPG = 1 + IPY = IPG + M + ING = IPG + NRG*NR + ICONN = ING +C + IF( .NOT.FIRST .AND. CONNEC ) THEN +C +C Restore the saved (M+L)*2*NOBR "connection" elements of +C U and Y into their appropriate position in sequential +C processing. The process is performed column-wise, in +C reverse order, first for Y and then for U. +C ICONN is a pointer to the first saved "connection" element. +C Workspace: need (M+L)*2*NOBR*(M+L+3). +C + IREV = ICONN + NR + ICOL = ICONN + 2*NR +C + DO 10 I = 2, M + L + IREV = IREV - NOBR2 + ICOL = ICOL - LDRWRK + CALL DCOPY( NOBR2, DWORK(IREV), 1, DWORK(ICOL), 1 ) + 10 CONTINUE +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR2, M, U, LDU, DWORK(ICONN+NOBR2), + $ LDRWRK ) + CALL DLACPY( 'Full', NOBR2, L, Y, LDY, + $ DWORK(ICONN+LDRWRK*M+NOBR2), LDRWRK ) + END IF +C + IF ( M.GT.0 ) THEN +C +C Let Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' + +C ... + u_(i+NSM-1)*u_(j+NSM-1)', +C where u_i' is the i-th row of U, j = 1 : 2s, i = 1 : j, +C NSM = NSMP - 2s, and Guu0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed +C till the current block for BATCH = 'I' or 'L'. The matrix +C Guu(i,j) is m-by-m, and Guu(j,j) is symmetric. The +C submatrices of the first block-row, Guu(1,j), are needed only. +C +C Compute/update Guu(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', M, NOBR2, ONE, + $ DWORK(ICONN), LDRWRK, UPD, DWORK(IPG), NRG ) + CALL DSYRK( 'Upper', 'Transpose', M, NSM, ONE, U, LDU, UPD, + $ DWORK(IPG), NRG ) + CALL MA02ED( 'Upper', M, DWORK(IPG), NRG ) +C + JD = 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 20 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Guu(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, + $ U, LDU, U(J,1), LDU, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + 20 CONTINUE +C + ELSE +C + DO 30 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Guu(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR2, + $ ONE, DWORK(ICONN), LDRWRK, DWORK(ICONN+J-1), + $ LDRWRK, UPD, DWORK(IPG+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NSM, ONE, + $ U, LDU, U(J,1), LDU, ONE, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + 30 CONTINUE +C + END IF +C +C Let Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' + +C ... + u_(i+NSM-1)*y_(j+NSM-1)', +C where u_i' is the i-th row of U, y_j' is the j-th row +C of Y, j = 1 : 2s, i = 1 : 2s, NSM = NSMP - 2s, and +C Guy0(i,j) is a zero matrix for BATCH = 'O' or 'F', and it +C is the matrix Guy(i,j) computed till the current block for +C BATCH = 'I' or 'L'. Guy(i,j) is m-by-L. The submatrices +C of the first block-row, Guy(1,j), as well as the transposes +C of the submatrices of the first block-column, i.e., Gyu(1,j), +C are needed only. +C + JD = MMNOBR + 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 40 J = 1, NOBR2 +C +C Compute/update Guy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, + $ U, LDU, Y(J,1), LDY, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + JD = JD + L + 40 CONTINUE +C + ELSE +C + DO 50 J = 1, NOBR2 +C +C Compute/update Guy(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR2, + $ ONE, DWORK(ICONN), LDRWRK, + $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NSM, ONE, + $ U, LDU, Y(J,1), LDY, ONE, + $ DWORK(IPG+(JD-1)*NRG), NRG ) + JD = JD + L + 50 CONTINUE +C + END IF +C +C Now, the first M "positive" generators have been built. +C Transpose Guy(1,1) in the first block of the Y part of the +C "positive" generators. +C + DO 60 J = 1, L + CALL DCOPY( M, DWORK(IPG+(MMNOBR+J-1)*NRG), 1, + $ DWORK(IPY+J-1), NRG ) + 60 CONTINUE +C + JD = 1 +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 70 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Gyu(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, + $ Y, LDY, U(J,1), LDU, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + 70 CONTINUE +C + ELSE +C + DO 80 J = 2, NOBR2 + JD = JD + M +C +C Compute/update Gyu(1,j) for sequential processing +C with connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NOBR2, + $ ONE, DWORK(ICONN+LDRWRK*M), LDRWRK, + $ DWORK(ICONN+J-1), LDRWRK, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', L, M, NSM, ONE, + $ Y, LDY, U(J,1), LDU, ONE, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + 80 CONTINUE +C + END IF +C + END IF +C +C Let Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... + +C y_(i+NSM-1)*y_(i+NSM-1)', +C where y_i' is the i-th row of Y, j = 1 : 2s, i = 1 : j, +C NSM = NSMP - 2s, and Gyy0(i,j) is a zero matrix for +C BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till +C the current block for BATCH = 'I' or 'L'. Gyy(i,j) is L-by-L, +C and Gyy(j,j) is symmetric. The submatrices of the first +C block-row, Gyy(1,j), are needed only. +C + JD = MMNOBR + 1 +C +C Compute/update Gyy(1,1). +C + IF( .NOT.FIRST .AND. CONNEC ) + $ CALL DSYRK( 'Upper', 'Transpose', L, NOBR2, ONE, + $ DWORK(ICONN+LDRWRK*M), LDRWRK, UPD, + $ DWORK(IPY+MMNOBR*NRG), NRG ) + CALL DSYRK( 'Upper', 'Transpose', L, NSM, ONE, Y, LDY, UPD, + $ DWORK(IPY+MMNOBR*NRG), NRG ) + CALL MA02ED( 'Upper', L, DWORK(IPY+MMNOBR*NRG), NRG ) +C + IF( FIRST .OR. .NOT.CONNEC ) THEN +C + DO 90 J = 2, NOBR2 + JD = JD + L +C +C Compute/update Gyy(1,j). +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, + $ LDY, Y(J,1), LDY, UPD, DWORK(IPY+(JD-1)*NRG), + $ NRG ) + 90 CONTINUE +C + ELSE +C + DO 100 J = 2, NOBR2 + JD = JD + L +C +C Compute/update Gyy(1,j) for sequential processing with +C connected blocks. +C + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR2, ONE, + $ DWORK(ICONN+LDRWRK*M), LDRWRK, + $ DWORK(ICONN+LDRWRK*M+J-1), LDRWRK, UPD, + $ DWORK(IPY+(JD-1)*NRG), NRG ) + CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NSM, ONE, Y, + $ LDY, Y(J,1), LDY, ONE, DWORK(IPY+(JD-1)*NRG), + $ NRG ) + 100 CONTINUE +C + END IF +C + IF ( .NOT.LAST ) THEN + IF ( FIRST ) THEN +C +C For sequential processing, save the first 2*NOBR-1 rows of +C the first block of U and Y in the appropriate +C (M+L)*(2*NOBR-1) locations of DWORK starting at (1+M)*NRG. +C These will be used to construct the last negative generator. +C + JD = NRG + IF ( M.GT.0 ) THEN + CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) +C + DO 110 J = 1, NOBR21 + JD = JD + MNRG + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + 110 CONTINUE +C + JD = JD + MNRG + END IF + CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) +C + DO 120 J = 1, NOBR21 + JD = JD + LNRG + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + 120 CONTINUE +C + END IF +C + IF ( CONNEC ) THEN +C +C For sequential processing with connected data blocks, +C save the remaining ("connection") elements of U and Y +C in (M+L)*2*NOBR locations of DWORK starting at ICONN. +C + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', NOBR2, M, U(NS,1), LDU, + $ DWORK(ICONN), NOBR2 ) + CALL DLACPY( 'Full', NOBR2, L, Y(NS,1), LDY, + $ DWORK(ICONN+MMNOBR), NOBR2 ) + END IF +C +C Return to get new data. +C + ICYCLE = ICYCLE + 1 + IF ( ICYCLE.GT.MAXCYC ) + $ IWARN = 1 + RETURN + END IF +C + IF ( LAST ) THEN +C +C Try to compute the R factor. +C +C Scale the first M+L positive generators and set the first +C M+L negative generators. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+M+L. +C + JWORK = NRG*2*NR + 1 + CALL DCOPY( M, DWORK(IPG), NRG+1, DWORK(JWORK), 1 ) + CALL DCOPY( L, DWORK(IPY+MMNOBR*NRG), NRG+1, DWORK(JWORK+M), + $ 1 ) +C + DO 130 I = 1, M + L + IWORK(I) = IDAMAX( M+L, DWORK(JWORK), 1 ) + DWORK(JWORK+IWORK(I)-1) = ZERO + 130 CONTINUE +C + DO 150 I = 1, M + L + IMAX = IWORK(I) + IF ( IMAX.LE.M ) THEN + ICOL = IMAX + ELSE + ICOL = MMNOBR - M + IMAX + END IF + BETA = SQRT( ABS( DWORK(IPG+IMAX-1+(ICOL-1)*NRG) ) ) + IF ( BETA.EQ.ZERO ) THEN +C +C Error exit. +C + INFO = 1 + RETURN + END IF + CALL DSCAL( NR, ONE / BETA, DWORK(IPG+IMAX-1), NRG ) + CALL DCOPY( NR, DWORK(IPG+IMAX-1), NRG, DWORK(ING+IMAX-1), + $ NRG ) + DWORK(IPG+IMAX-1+(ICOL-1)*NRG) = BETA + DWORK(ING+IMAX-1+(ICOL-1)*NRG) = ZERO +C + DO 140 J = I + 1, M + L + DWORK(IPG+IWORK(J)-1+(ICOL-1)*NRG) = ZERO + 140 CONTINUE +C + 150 CONTINUE +C +C Compute the last two generators. +C + IF ( .NOT.FIRST ) THEN +C +C For sequential processing, move the stored last negative +C generator. +C + CALL DCOPY( NR, DWORK(NRG), NRG, DWORK(ING+NRG-1), NRG ) + END IF +C + JD = NRG + IF ( M.GT.0 ) THEN +C + DO 160 J = NS, NSMP + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + JD = JD + MNRG + 160 CONTINUE +C + END IF +C + DO 170 J = NS, NSMP + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + JD = JD + LNRG + 170 CONTINUE +C + IF ( FIRST ) THEN + IF ( M.GT.0 ) THEN + CALL DCOPY( M, DUM, 0, DWORK(JD), NRG ) +C + DO 180 J = 1, NOBR21 + JD = JD + MNRG + CALL DCOPY( M, U(J,1), LDU, DWORK(JD), NRG ) + 180 CONTINUE +C + JD = JD + MNRG + END IF + CALL DCOPY( L, DUM, 0, DWORK(JD), NRG ) +C + DO 190 J = 1, NOBR21 + JD = JD + LNRG + CALL DCOPY( L, Y(J,1), LDY, DWORK(JD), NRG ) + 190 CONTINUE +C + END IF +C + ITAU = JWORK + IPGC = IPG + MMNOBR*NRG +C + IF ( M.GT.0 ) THEN +C +C Process the input part of the generators. +C + JWORK = ITAU + M +C +C Reduce the first M columns of the matrix G1 of positive +C generators to an upper triangular form. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*M; +C prefer (M+L)*4*NOBR*(M+L+1)+M+M*NB. +C + INGC = ING + CALL DGEQRF( NRG, M, DWORK(IPG), NRG, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR; +C prefer (M+L)*4*NOBR*(M+L+1)+M+ +C ((M+L)*2*NOBR-M)*NB. +C + CALL DORMQR( 'Left', 'Transpose', NRG, NR-M, M, DWORK(IPG), + $ NRG, DWORK(ITAU), DWORK(IPG+MNRG), NRG, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Annihilate, column by column, the first M columns of the +C matrix G2 of negative generators, using Householder +C transformations and modified hyperbolic plane rotations. +C In the DLARF calls, ITAU is a pointer to the workspace +C array. +C + DO 210 J = 1, M + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, NR-J, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPG+(J-1)*(NRG+1)), DWORK(INGC), CS, + $ SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 200 I = J*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 200 CONTINUE +C + INGC = INGP + 210 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', M, NR, DWORK(IPG), NRG, R, LDR ) +C + DO 220 I = ( MMNOBR - M )*NRG, MNRG, -MNRG + CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, + $ DWORK(IPG+I), NRG ) + 220 CONTINUE +C + DO 230 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 230 CONTINUE +C + CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) +C +C Update the input part of generators using Schur algorithm. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*(M+L)-M. +C + JDS = MNRG + ICOL = M +C + DO 280 K = 2, NOBR2 + CALL MB04OD( 'Full', M, NR-ICOL-M, L+1, DWORK(IPG+JDS), + $ NRG, DWORK(IPY+JDS), NRG, + $ DWORK(IPG+JDS+MNRG), NRG, + $ DWORK(IPY+JDS+MNRG), NRG, DWORK(ITAU), + $ DWORK(JWORK) ) +C + DO 250 J = 1, M + ICJ = ICOL + J + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, NR-ICJ, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPG+J-1+(ICJ-1)*NRG), DWORK(INGC), + $ CS, SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 240 I = ICJ*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 240 CONTINUE +C + INGC = INGP + 250 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', M, NR-ICOL, DWORK(IPG+JDS), NRG, + $ R(ICOL+1,ICOL+1), LDR ) + ICOL = ICOL + M +C + DO 260 I = ( MMNOBR - M )*NRG, ICOL*NRG, -MNRG + CALL DLACPY( 'Full', M, M, DWORK(IPG+I-MNRG), NRG, + $ DWORK(IPG+I), NRG ) + 260 CONTINUE +C + DO 270 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', M, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 270 CONTINUE +C + CALL DLASET( 'Full', M, L, ZERO, ZERO, DWORK(IPGC), NRG ) + JDS = JDS + MNRG + 280 CONTINUE +C + END IF +C +C Process the output part of the generators. +C + JWORK = ITAU + L +C +C Reduce the first L columns of the submatrix +C G1(1:M+L+1,2*M*NOBR+1:2*(M+L)*NOBR) to upper triangular form. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*L; +C prefer (M+L)*4*NOBR*(M+L+1)+L+L*NB. +C + INGC = ING + MMNOBR*NRG + CALL DGEQRF( NRG, L, DWORK(IPGC), NRG, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need (M+L)*4*NOBR*(M+L+1)+L*2*NOBR; +C prefer (M+L)*4*NOBR*(M+L+1)+L+(L*2*NOBR-L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', NRG, LLNOBR-L, L, + $ DWORK(IPGC), NRG, DWORK(ITAU), DWORK(IPGC+LNRG), + $ NRG, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Annihilate, column by column, the first L columns of the +C output part of the matrix G2 of negative generators, using +C Householder transformations and modified hyperbolic rotations. +C + DO 300 J = 1, L + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, LLNOBR-J, DWORK(INGC), 1, TAU, + $ DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPGC+(J-1)*(NRG+1)), DWORK(INGC), CS, SN, + $ IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 290 I = ( J + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 290 CONTINUE +C + INGC = INGP + 300 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', L, LLNOBR, DWORK(IPGC), NRG, + $ R(MMNOBR+1,MMNOBR+1), LDR ) +C + DO 310 I = ( NR - L )*NRG, ( MMNOBR + L )*NRG, -LNRG + CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 310 CONTINUE +C +C Update the output part of generators using the Schur algorithm. +C Workspace: need (M+L)*4*NOBR*(M+L+1)+2*NOBR*L-L. +C + JDS = LNRG + ICOL = L +C + DO 350 K = 2, NOBR2 + CALL MB04OD( 'Full', L, LLNOBR-ICOL-L, M+1, DWORK(IPGC+JDS), + $ NRG, DWORK(IPGC+L+JDS), NRG, + $ DWORK(IPGC+JDS+LNRG), NRG, + $ DWORK(IPGC+L+JDS+LNRG), NRG, DWORK(ITAU), + $ DWORK(JWORK) ) +C + DO 330 J = 1, L + ICJ = ICOL + J + CALL DLARFG( NRG, DWORK(INGC), DWORK(INGC+1), 1, TAU ) + BETA = DWORK(INGC) + DWORK(INGC) = ONE + INGP = INGC + NRG + CALL DLARF( 'Left', NRG, LLNOBR-ICJ, DWORK(INGC), 1, + $ TAU, DWORK(INGP), NRG, DWORK(ITAU) ) + DWORK(INGC) = BETA +C +C Compute the coefficients of the modified hyperbolic +C rotation. +C + CALL MA02FD( DWORK(IPGC+J-1+(ICJ-1)*NRG), DWORK(INGC), + $ CS, SN, IERR ) + IF( IERR.NE.0 ) THEN +C +C Error return: the matrix H'*H is not (numerically) +C positive definite. +C + INFO = 1 + RETURN + END IF +C + DO 320 I = ( ICJ + MMNOBR )*NRG, ( NR - 1 )*NRG, NRG + DWORK(IPG+J-1+I) = ( DWORK(IPG+J-1+I) - + $ SN * DWORK(ING+I) ) / CS + DWORK(ING+I) = -SN * DWORK(IPG+J-1+I) + + $ CS * DWORK(ING+I) + 320 CONTINUE +C + INGC = INGP + 330 CONTINUE +C +C Save one block row of R, and shift the generators for the +C calculation of the following row. +C + CALL DLACPY( 'Upper', L, LLNOBR-ICOL, DWORK(IPGC+JDS), NRG, + $ R(MMNOBR+ICOL+1,MMNOBR+ICOL+1), LDR ) +C + DO 340 I = ( NR - L )*NRG, ( MMNOBR + ICOL )*NRG, -LNRG + CALL DLACPY( 'Full', L, L, DWORK(IPG+I-LNRG), NRG, + $ DWORK(IPG+I), NRG ) + 340 CONTINUE +C + ICOL = ICOL + L + JDS = JDS + LNRG + 350 CONTINUE +C + IF ( MOESP .AND. M.GT.0 ) THEN +C +C For the MOESP algorithm, interchange the past and future +C input parts of the R factor, and compute the new R factor +C using a specialized QR factorization. A tailored fast +C QR factorization for the MOESP algorithm could be slightly +C more efficient. +C + DO 360 J = 1, MNOBR + CALL DSWAP( J, R(1,J), 1, R(1,MNOBR+J), 1 ) + CALL DCOPY( MNOBR, R(J+1,MNOBR+J), 1, R(J+1,J), 1 ) + CALL DCOPY( MMNOBR-J, DUM, 0, R(J+1,MNOBR+J), 1 ) + 360 CONTINUE +C +C Triangularize the first two block columns (using structure), +C and apply the transformation to the corresponding part of +C the remaining block columns. +C Workspace: need 2*(M+L)*NOBR. +C + ITAU = 1 + JWORK = ITAU + MMNOBR + CALL MB04ID( MMNOBR, MMNOBR, MNOBR-1, LLNOBR, R, LDR, + $ R(1,MMNOBR+1), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF + END IF +C + NSMPSM = 0 + ICYCLE = 1 +C +C Return optimal workspace in DWORK(1). +C + DWORK( 1 ) = MAXWRK + MAXWRK = 1 + RETURN +C +C *** Last line of IB01MY *** + END diff --git a/mex/sources/libslicot/IB01ND.f b/mex/sources/libslicot/IB01ND.f new file mode 100644 index 000000000..ad315b4cd --- /dev/null +++ b/mex/sources/libslicot/IB01ND.f @@ -0,0 +1,731 @@ + SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the singular value decomposition (SVD) giving the system +C order, using the triangular factor of the concatenated block +C Hankel matrices. Related preliminary calculations needed for +C computing the system matrices are also performed. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C JOBD CHARACTER*1 +C Specifies whether or not the matrices B and D should later +C be computed using the MOESP approach, as follows: +C = 'M': the matrices B and D should later be computed +C using the MOESP approach; +C = 'N': the matrices B and D should not be computed using +C the MOESP approach. +C This parameter is not relevant for METH = 'N'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C block Hankel matrices. NOBR > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C R (input/output) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper +C triangular part of this array must contain the upper +C triangular factor R from the QR factorization of the +C concatenated block Hankel matrices. Denote R_ij, +C i,j = 1:4, the ij submatrix of R, partitioned by +C M*NOBR, M*NOBR, L*NOBR, and L*NOBR rows and columns. +C On exit, if INFO = 0, the leading +C 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this +C array contains the matrix S, the processed upper +C triangular factor R, as required by other subroutines. +C Specifically, let S_ij, i,j = 1:4, be the ij submatrix +C of S, partitioned by M*NOBR, L*NOBR, M*NOBR, and +C L*NOBR rows and columns. The submatrix S_22 contains +C the matrix of left singular vectors needed subsequently. +C Useful information is stored in S_11 and in the +C block-column S_14 : S_44. For METH = 'M' and JOBD = 'M', +C the upper triangular part of S_31 contains the upper +C triangular factor in the QR factorization of the matrix +C R_1c = [ R_12' R_22' R_11' ]', and S_12 contains the +C corresponding leading part of the transformed matrix +C R_2c = [ R_13' R_23' R_14' ]'. For METH = 'N', the +C subarray S_41 : S_43 contains the transpose of the +C matrix contained in S_14 : S_34. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ), +C for METH = 'M' and JOBD = 'M'; +C LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or +C for METH = 'N'. +C +C SV (output) DOUBLE PRECISION array, dimension ( L*NOBR ) +C The singular values of the relevant part of the triangular +C factor from the QR factorization of the concatenated block +C Hankel matrices. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not used for METH = 'M'. +C +C Workspace +C +C IWORK INTEGER array, dimension ((M+L)*NOBR) +C This parameter is not referenced for METH = 'M'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and, for METH = 'N', DWORK(2) and DWORK(3) +C contain the reciprocal condition numbers of the +C triangular factors of the matrices U_f and r_1 [6]. +C On exit, if INFO = -12, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ), +C if METH = 'M' and JOBD = 'M'; +C LDWORK >= 5*L*NOBR, if METH = 'M' and JOBD = 'N'; +C LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N'. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problems with coefficient matrix +C U_f, used for computing the weighted oblique +C projection (for METH = 'N'), have a rank-deficient +C coefficient matrix; +C = 5: the least squares problem with coefficient matrix +C r_1 [6], used for computing the weighted oblique +C projection (for METH = 'N'), has a rank-deficient +C coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C A singular value decomposition (SVD) of a certain matrix is +C computed, which reveals the order n of the system as the number +C of "non-zero" singular values. For the MOESP approach, this matrix +C is [ R_24' R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s), +C where R is the upper triangular factor R constructed by SLICOT +C Library routine IB01MD. For the N4SID approach, a weighted +C oblique projection is computed from the upper triangular factor R +C and its SVD is then found. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Verhaegen M. +C Subspace Model Identification. Part 3: Analysis of the +C ordinary output-error state-space model identification +C algorithm. +C Int. J. Control, 58, pp. 555-586, 1993. +C +C [3] Verhaegen M. +C Identification of the deterministic part of MIMO state space +C models given in innovations form from input-output data. +C Automatica, Vol.30, No.1, pp.61-74, 1994. +C +C [4] Van Overschee, P., and De Moor, B. +C N4SID: Subspace Algorithms for the Identification of +C Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [5] Van Overschee, P., and De Moor, B. +C Subspace Identification for Linear Systems: Theory - +C Implementation - Applications. +C Kluwer Academic Publishers, Boston/London/Dordrecht, 1996. +C +C [6] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 +C The algorithm requires 0(((m+l)s) ) floating point operations. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C Feb. 2000, Feb. 2001, Feb. 2004, March 2005. +C +C KEYWORDS +C +C Identification methods, multivariable systems, QR decomposition, +C singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDR, LDWORK, M, NOBR + CHARACTER JOBD, METH +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), R(LDR, *), SV(*) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION EPS, RCOND1, RCOND2, SVLMAX, THRESH, TOLL + INTEGER I, IERR, ITAU, ITAU2, ITAU3, J, JWORK, LLMNOB, + $ LLNOBR, LMMNOB, LMNOBR, LNOBR, MAXWRK, MINWRK, + $ MMNOBR, MNOBR, NR, NR2, NR3, NR4, NRSAVE, RANK, + $ RANK1 + LOGICAL JOBDM, MOESP, N4SID +C .. Local Arrays .. + DOUBLE PRECISION DUM(1), SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, + $ DTRCON, MA02AD, MB03OD, MB03UD, MB04ID, MB04IY, + $ MB04OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + JOBDM = LSAME( JOBD, 'M' ) + MNOBR = M*NOBR + LNOBR = L*NOBR + LLNOBR = LNOBR + LNOBR + LMNOBR = LNOBR + MNOBR + MMNOBR = MNOBR + MNOBR + LMMNOB = MMNOBR + LNOBR + NR = LMNOBR + LMNOBR + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( NOBR.LE.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LE.0 ) THEN + INFO = -5 + ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND. + $ LDR.LT.3*MNOBR ) ) THEN + INFO = -7 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MINWRK = 1 + IF ( LDWORK.GE.1 ) THEN + IF ( MOESP ) THEN + MINWRK = 5*LNOBR + IF ( JOBDM ) + $ MINWRK = MAX( MMNOBR - NOBR, LMNOBR, MINWRK ) + MAXWRK = LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, + $ LNOBR, -1, -1 ) + ELSE +C + MINWRK = MAX( MINWRK, 5*LMNOBR + 1 ) + MAXWRK = MAX( MNOBR + MNOBR*ILAENV( 1, 'DGEQRF', ' ', + $ MMNOBR, MNOBR, -1, -1 ), + $ MNOBR + LLNOBR*ILAENV( 1, 'DORMQR', 'LT', + $ MMNOBR, LLNOBR, MNOBR, -1 ) ) + MAXWRK = MAX( MAXWRK, MNOBR + LNOBR*ILAENV( 1, 'DORMQR', + $ 'LN', MMNOBR, LNOBR, MNOBR, + $ -1 ) ) + MAXWRK = MAX( MAXWRK, LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', + $ ' ', LMMNOB, LNOBR, -1, -1 ) ) + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -12 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01ND', -INFO ) + RETURN + END IF +C +C Compute pointers to the needed blocks of R. +C + NR2 = MNOBR + 1 + NR3 = MMNOBR + 1 + NR4 = LMMNOB + 1 + ITAU = 1 + JWORK = ITAU + MNOBR +C + IF( MOESP ) THEN +C +C MOESP approach. +C + IF( M.GT.0 .AND. JOBDM ) THEN +C +C Rearrange the blocks of R: +C Copy the (1,1) block into the position (3,2) and +C copy the (1,4) block into (3,3). +C + CALL DLACPY( 'Upper', MNOBR, MNOBR, R, LDR, R(NR3,NR2), + $ LDR ) + CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR4), LDR, + $ R(NR3,NR3), LDR ) +C +C Using structure, triangularize the matrix +C R_1c = [ R_12' R_22' R_11' ]' +C and then apply the transformations to the matrix +c R_2c = [ R_13' R_23' R_14' ]'. +C Workspace: need M*NOBR + MAX(M-1,L)*NOBR. +C + CALL MB04OD( 'Upper', MNOBR, LNOBR, MNOBR, R(NR2,NR2), LDR, + $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR3,NR3), + $ LDR, DWORK(ITAU), DWORK(JWORK) ) + CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LNOBR, R(1,NR2), LDR, + $ R(1,NR3), LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Copy the leading M*NOBR x M*NOBR and M*NOBR x L*NOBR +C submatrices of R_1c and R_2c, respectively, into their +C final positions, required by SLICOT Library routine IB01PD. +C + CALL DLACPY( 'Upper', MNOBR, MNOBR, R(1,NR2), LDR, + $ R(LMNOBR+1,1), LDR ) + CALL DLACPY( 'Full', MNOBR, LNOBR, R(1,NR3), LDR, R(1,NR2), + $ LDR ) + END IF +C +C Copy [ R_24' R_34' ]' in [ R_22' R_32' ]'. +C + CALL DLACPY( 'Full', LMNOBR, LNOBR, R(NR2,NR4), LDR, + $ R(NR2,NR2), LDR ) +C +C Triangularize the matrix in [ R_22' R_32' ]'. +C Workspace: need 2*L*NOBR; prefer L*NOBR + L*NOBR*NB. +C + JWORK = ITAU + LNOBR + CALL DGEQRF( LMNOBR, LNOBR, R(NR2,NR2), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C + ELSE +C +C N4SID approach. +C + DUM(1) = ZERO + LLMNOB = LLNOBR + MNOBR +C +C Set the precision parameters. A threshold value EPS**(2/3) is +C used for deciding to use pivoting or not, where EPS is the +C relative machine precision (see LAPACK Library routine DLAMCH). +C + TOLL = TOL + EPS = DLAMCH( 'Precision' ) + THRESH = EPS**( TWO/THREE ) +C + IF( M.GT.0 ) THEN +C +C For efficiency of later calculations, interchange the first +C two block-columns. The corresponding submatrices are +C redefined according to their new position. +C + DO 10 I = 1, MNOBR + CALL DSWAP( I, R(1,I), 1, R(1,MNOBR+I), 1 ) + CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(I+1,I), 1 ) + CALL DCOPY( MMNOBR-I, DUM, 0, R(I+1,MNOBR+I), 1 ) + 10 CONTINUE +C +C Now, +C +C U_f = [ R_11' R_21' 0 0 ]', +C U_p = [ R_12' 0 0 0 ]', +C Y_p = [ R_13' R_23' R_33' 0 ]', and +C Y_f = [ R_14' R_24' R_34' R_44' ]', +C +C where R_21, R_12, R_33, and R_44 are upper triangular. +C Define W_p := [ U_p Y_p ]. +C +C Prepare the computation of residuals of the two least +C squares problems giving the weighted oblique projection P: +C +C r_1 = W_p - U_f X_1, X_1 = arg min || U_f X - W_p ||, +C r_2 = Y_f - U_f X_2, X_2 = arg min || U_f X - Y_f ||, +C +C P = (arg min || r_1 X - r_2 ||)' r_1'. (1) +C +C Alternately, P' is given by the projection +C P' = Q_1 (Q_1)' r_2, +C where Q_1 contains the first k columns of the orthogonal +C matrix in the QR factorization of r_1, k := rank(r_1). +C +C Triangularize the matrix U_f = q r (using structure), and +C apply the transformation q' to the corresponding part of +C the matrices W_p, and Y_f. +C Workspace: need 2*(M+L)*NOBR. +C + CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LLMNOB, R, LDR, + $ R(1,NR2), LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Save updated Y_f (transposed) in the last block-row of R. +C + CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), + $ LDR ) +C +C Check the condition of the triangular factor r and decide +C to use pivoting or not. +C Workspace: need 4*M*NOBR. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R, LDR, + $ RCOND1, DWORK(JWORK), IWORK, IERR ) +C + IF( TOLL.LE.ZERO ) + $ TOLL = MNOBR*MNOBR*EPS + IF ( RCOND1.GT.MAX( TOLL, THRESH ) ) THEN +C +C U_f is considered full rank and no pivoting is used. +C + CALL DLASET( 'Full', MNOBR, LLMNOB, ZERO, ZERO, R(1,NR2), + $ LDR ) + ELSE +C +C Save information about q in the (2,1) block of R. +C Use QR factorization with column pivoting, r P = Q R. +C Information on Q is stored in the strict lower triangle +C of R_11 and in DWORK(ITAU2). +C + DO 20 I = 1, MNOBR - 1 + DO 15 J = MMNOBR, NR2, -1 + R(J,I) = R(J-MNOBR+I,I) + 15 CONTINUE + CALL DCOPY( MNOBR-I, DUM, 0, R(I+1,I), 1 ) + IWORK(I) = 0 + 20 CONTINUE +C + IWORK(MNOBR) = 0 +C +C Workspace: need 5*M*NOBR+1. +C prefer 4*M*NOBR + (M*NOBR+1)*NB. +C + ITAU2 = JWORK + JWORK = ITAU2 + MNOBR + SVLMAX = ZERO + CALL MB03OD( 'QR', MNOBR, MNOBR, R, LDR, IWORK, TOLL, + $ SVLMAX, DWORK(ITAU2), RANK, SVAL, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need 2*M*NOBR + (M+2*L)*NOBR; +C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', MNOBR, LLMNOB, MNOBR, + $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( RANK.LT.MNOBR ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 4 + END IF +C +C Determine residuals r_1 and r_2: premultiply by Q and +C then by q. +C Workspace: need 2*M*NOBR + (M+2*L)*NOBR); +C prefer 2*M*NOBR + (M+2*L)*NOBR*NB. +C + CALL DLASET( 'Full', RANK, LLMNOB, ZERO, ZERO, R(1,NR2), + $ LDR ) + CALL DORMQR( 'Left', 'NoTranspose', MNOBR, LLMNOB, MNOBR, + $ R, LDR, DWORK(ITAU2), R(1,NR2), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU2 +C +C Restore the transformation q. +C + DO 30 I = 1, MNOBR - 1 + DO 25 J = NR2, MMNOBR + R(J-MNOBR+I,I) = R(J,I) + 25 CONTINUE + 30 CONTINUE +C + END IF +C +C Premultiply by the transformation q (apply transformations +C in backward order). +C Workspace: need M*NOBR + (M+2*L)*NOBR; +C prefer larger. +C + CALL MB04IY( 'Left', 'NoTranspose', MMNOBR, LLMNOB, MNOBR, + $ MNOBR-1, R, LDR, DWORK(ITAU), R(1,NR2), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + ELSE +C +C Save Y_f (transposed) in the last block-row of R. +C + CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), + $ LDR ) + RCOND1 = ONE + END IF +C +C Triangularize the matrix r_1 for determining the oblique +C projection P in least squares problem in (1). Exploit the +C fact that the third block-row of r_1 has the structure +C [ 0 T ], where T is an upper triangular matrix. Then apply +C the corresponding transformations Q' to the matrix r_2. +C Workspace: need 2*M*NOBR; +C prefer M*NOBR + M*NOBR*NB. +C + CALL DGEQRF( MMNOBR, MNOBR, R(1,NR2), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Workspace: need M*NOBR + 2*L*NOBR; +C prefer M*NOBR + 2*L*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', MMNOBR, LLNOBR, MNOBR, + $ R(1,NR2), LDR, DWORK(ITAU), R(1,NR3), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + NRSAVE = NR2 +C + ITAU2 = JWORK + JWORK = ITAU2 + LNOBR + CALL MB04ID( LMNOBR, LNOBR, LNOBR-1, LNOBR, R(NR2,NR3), LDR, + $ R(NR2,NR4), LDR, DWORK(ITAU2), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Check the condition of the triangular matrix of order (m+l)*s +C just determined, and decide to use pivoting or not. +C Workspace: need 4*(M+L)*NOBR. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LMNOBR, R(1,NR2), + $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) +C + IF( TOL.LE.ZERO ) + $ TOLL = LMNOBR*LMNOBR*EPS + IF ( RCOND2.LE.MAX( TOLL, THRESH ) ) THEN + IF ( M.GT.0 ) THEN +C +C Save information about Q in R_11 (in the strict lower +C triangle), R_21 and R_31 (transposed information). +C + CALL DLACPY( 'Lower', MMNOBR-1, MNOBR, R(2,NR2), LDR, + $ R(2,1), LDR ) + NRSAVE = 1 +C + DO 40 I = NR2, LMNOBR + CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(MNOBR+I,1), + $ LDR ) + 40 CONTINUE +C + END IF +C + CALL DLASET( 'Lower', LMNOBR-1, LMNOBR-1, ZERO, ZERO, + $ R(2,NR2), LDR ) +C +C Use QR factorization with column pivoting. +C Workspace: need 5*(M+L)*NOBR+1. +C prefer 4*(M+L)*NOBR + ((M+L)*NOBR+1)*NB. +C + DO 50 I = 1, LMNOBR + IWORK(I) = 0 + 50 CONTINUE +C + ITAU3 = JWORK + JWORK = ITAU3 + LMNOBR + SVLMAX = ZERO + CALL MB03OD( 'QR', LMNOBR, LMNOBR, R(1,NR2), LDR, IWORK, + $ TOLL, SVLMAX, DWORK(ITAU3), RANK1, SVAL, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need 2*(M+L)*NOBR + L*NOBR; +C prefer 2*(M+L)*NOBR + L*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', LMNOBR, LNOBR, LMNOBR, + $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( RANK1.LT.LMNOBR ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 5 + END IF +C +C Apply the orthogonal transformations, in backward order, to +C [r_2(1:rank(r_1),:)' 0]', to obtain P'. +C Workspace: need 2*(M+L)*NOBR + L*NOBR; +C prefer 2*(M+L)*NOBR + L*NOBR*NB. +C + CALL DLASET( 'Full', LMNOBR-RANK1, LNOBR, ZERO, ZERO, + $ R(RANK1+1,NR4), LDR ) + CALL DORMQR( 'Left', 'NoTranspose', LMNOBR, LNOBR, LMNOBR, + $ R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU3 +C + IF ( M.GT.0 ) THEN +C +C Restore the saved transpose matrix from R_31. +C + DO 60 I = NR2, LMNOBR + CALL DCOPY( MNOBR, R(MNOBR+I,1), LDR, R(I+1,MNOBR+I), + $ 1 ) + 60 CONTINUE +C + END IF +C + END IF +C +C Workspace: need M*NOBR + L*NOBR; +C prefer larger. +C + CALL MB04IY( 'Left', 'NoTranspose', LMNOBR, LNOBR, LNOBR, + $ LNOBR-1, R(NR2,NR3), LDR, DWORK(ITAU2), + $ R(NR2,NR4), LDR, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need M*NOBR + L*NOBR; +C prefer M*NOBR + L*NOBR*NB. +C + JWORK = ITAU2 + CALL DORMQR( 'Left', 'NoTranspose', MMNOBR, LNOBR, MNOBR, + $ R(1,NRSAVE), LDR, DWORK(ITAU), R(1,NR4), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Now, the matrix P' is available in R_14 : R_34. +C Triangularize the matrix P'. +C Workspace: need 2*L*NOBR; +C prefer L*NOBR + L*NOBR*NB. +C + JWORK = ITAU + LNOBR + CALL DGEQRF( LMMNOB, LNOBR, R(1,NR4), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Copy the triangular factor to its final position, R_22. +C + CALL DLACPY( 'Upper', LNOBR, LNOBR, R(1,NR4), LDR, R(NR2,NR2), + $ LDR ) +C +C Restore Y_f. +C + CALL MA02AD( 'Full', LNOBR, LMMNOB, R(NR4,1), LDR, R(1,NR4), + $ LDR ) + END IF +C +C Find the singular value decomposition of R_22. +C Workspace: need 5*L*NOBR. +C + CALL MB03UD( 'NoVectors', 'Vectors', LNOBR, R(NR2,NR2), LDR, + $ DUM, 1, SV, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C +C Transpose R(m*s+1:(m+L)*s,m*s+1:(m+L)*s) in-situ; its +C columns will then be the singular vectors needed subsequently. +C + DO 70 I = NR2+1, LMNOBR + CALL DSWAP( LMNOBR-I+1, R(I,I-1), 1, R(I-1,I), LDR ) + 70 CONTINUE +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C numbers, if METH = 'N'. +C + DWORK(1) = MAXWRK + IF ( N4SID ) THEN + DWORK(2) = RCOND1 + DWORK(3) = RCOND2 + END IF + RETURN +C +C *** Last line of IB01ND *** + END diff --git a/mex/sources/libslicot/IB01OD.f b/mex/sources/libslicot/IB01OD.f new file mode 100644 index 000000000..69d22c5ea --- /dev/null +++ b/mex/sources/libslicot/IB01OD.f @@ -0,0 +1,214 @@ + SUBROUTINE IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the system order, based on the singular values of the +C relevant part of the triangular factor of the concatenated block +C Hankel matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C CTRL CHARACTER*1 +C Specifies whether or not the user's confirmation of the +C system order estimate is desired, as follows: +C = 'C': user's confirmation; +C = 'N': no confirmation. +C If CTRL = 'C', a reverse communication routine, IB01OY, +C is called, and, after inspecting the singular values and +C system order estimate, n, the user may accept n or set +C a new value. +C IB01OY is not called by the routine if CTRL = 'N'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the processed input and +C output block Hankel matrices. NOBR > 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C SV (input) DOUBLE PRECISION array, dimension ( L*NOBR ) +C The singular values of the relevant part of the triangular +C factor from the QR factorization of the concatenated block +C Hankel matrices. +C +C N (output) INTEGER +C The estimated order of the system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Absolute tolerance used for determining an estimate of +C the system order. If TOL >= 0, the estimate is +C indicated by the index of the last singular value greater +C than or equal to TOL. (Singular values less than TOL +C are considered as zero.) When TOL = 0, an internally +C computed default value, TOL = NOBR*EPS*SV(1), is used, +C where SV(1) is the maximal singular value, and EPS is +C the relative machine precision (see LAPACK Library routine +C DLAMCH). When TOL < 0, the estimate is indicated by the +C index of the singular value that has the largest +C logarithmic gap to its successor. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 3: all singular values were exactly zero, hence N = 0. +C (Both input and output were identically zero.) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The singular values are compared to the given, or default TOL, and +C the estimated order n is returned, possibly after user's +C confirmation. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C August 2000. +C +C KEYWORDS +C +C Identification methods, multivariable systems, singular value +C decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, N, NOBR + CHARACTER CTRL +C .. Array Arguments .. + DOUBLE PRECISION SV(*) +C .. Local Scalars .. + DOUBLE PRECISION GAP, RNRM, TOLL + INTEGER I, IERR, LNOBR + LOGICAL CONTRL +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL IB01OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, LOG10 +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + CONTRL = LSAME( CTRL, 'C' ) + LNOBR = L*NOBR + IWARN = 0 + INFO = 0 + IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( NOBR.LE.0 ) THEN + INFO = -2 + ELSE IF( L.LE.0 ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01OD', -INFO ) + RETURN + END IF +C +C Set TOL if necessay. +C + TOLL = TOL + IF ( TOLL.EQ.ZERO) + $ TOLL = DLAMCH( 'Precision' )*SV(1)*DBLE( NOBR ) +C +C Obtain the system order. +C + N = 0 + IF ( SV(1).NE.ZERO ) THEN + N = NOBR + IF ( TOLL.GE.ZERO) THEN +C +C Estimate n based on the tolerance TOLL. +C + DO 10 I = 1, NOBR - 1 + IF ( SV(I+1).LT.TOLL ) THEN + N = I + GO TO 30 + END IF + 10 CONTINUE + ELSE +C +C Estimate n based on the largest logarithmic gap between +C two consecutive singular values. +C + GAP = ZERO + DO 20 I = 1, NOBR - 1 + RNRM = SV(I+1) + IF ( RNRM.NE.ZERO ) THEN + RNRM = LOG10( SV(I) ) - LOG10( RNRM ) + IF ( RNRM.GT.GAP ) THEN + GAP = RNRM + N = I + END IF + ELSE + IF ( GAP.EQ.ZERO ) + $ N = I + GO TO 30 + END IF + 20 CONTINUE + END IF + END IF +C + 30 CONTINUE + IF ( N.EQ.0 ) THEN +C +C Return with N = 0 if all singular values are zero. +C + IWARN = 3 + RETURN + END IF +C + IF ( CONTRL ) THEN +C +C Ask confirmation of the system order. +C + CALL IB01OY( LNOBR, NOBR-1, N, SV, IERR ) + END IF + RETURN +C +C *** Last line of IB01OD *** + END diff --git a/mex/sources/libslicot/IB01OY.f b/mex/sources/libslicot/IB01OY.f new file mode 100644 index 000000000..1e475d751 --- /dev/null +++ b/mex/sources/libslicot/IB01OY.f @@ -0,0 +1,175 @@ + SUBROUTINE IB01OY( NS, NMAX, N, SV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To ask for user's confirmation of the system order found by +C SLICOT Library routine IB01OD. This routine may be modified, +C but its interface must be preserved. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NS (input) INTEGER +C The number of singular values. NS > 0. +C +C NMAX (input) INTEGER +C The maximum value of the system order. 0 <= NMAX <= NS. +C +C N (input/output) INTEGER +C On entry, the estimate of the system order computed by +C IB01OD routine. 0 <= N <= NS. +C On exit, the user's estimate of the system order, which +C could be identical with the input value of N. +C Note that the output value of N should be less than +C or equal to NMAX. +C +C SV (input) DOUBLE PRECISION array, dimension ( NS ) +C The singular values, in descending order, used for +C determining the system order. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Identification, parameter estimation, singular values, structure +C identification. +C +C ********************************************************************* +C +C .. Parameters .. + INTEGER INTRMN, OUTRMN + PARAMETER ( INTRMN = 5, OUTRMN = 6 ) +C INTRMN is the unit number for the (terminal) input device. +C OUTRMN is the unit number for the (terminal) output device. +C .. +C .. Scalar Arguments .. + INTEGER INFO, N, NMAX, NS +C .. +C .. Array Arguments .. + DOUBLE PRECISION SV( * ) +C .. +C .. Local Scalars .. + LOGICAL YES + INTEGER I + CHARACTER ANS +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF( NS.LE.0 ) THEN + INFO = -1 + ELSE IF( NMAX.LT.0 .OR. NMAX.GT.NS ) THEN + INFO = -2 + ELSE IF( N.LT.0 .OR. N.GT.NS ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01OY', -INFO ) + RETURN + END IF +C + WRITE( OUTRMN, '(/'' Singular values (in descending order) used'', + $ '' to estimate the system order:'', // + $ (5D15.8) )' ) ( SV(I), I = 1, NS ) + WRITE( OUTRMN, '(/'' Estimated order of the system, n = '', I5 )' + $ ) N + WRITE( OUTRMN, '(/'' Do you want this value of n to be used'', + $ '' to determine the system matrices?'' )' ) +C + 10 CONTINUE + WRITE( OUTRMN, '(/'' Type "yes" or "no": '' )' ) + READ ( INTRMN, '( A )' ) ANS + YES = LSAME( ANS, 'Y' ) + IF( YES ) THEN + IF( N.LE.NMAX ) THEN +C +C The value of n is adequate and has been confirmed. +C + RETURN + ELSE +C +C The estimated value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be less than or equal'', + $ '' to '', I5 )' ) NMAX + WRITE( OUTRMN, '( '' (It may be useful to restart'', + $ '' with a larger tolerance.)'' )' ) + GO TO 20 + END IF +C + ELSE IF( LSAME( ANS, 'N' ) ) THEN + GO TO 20 + ELSE +C +C Wrong answer should be re-entered. +C + GO TO 10 + END IF +C +C Enter the desired value of n. +C + 20 CONTINUE + WRITE( OUTRMN,'(/'' Enter the desired value of n (n <= '', I5, + $ ''); n = '' )' ) NMAX + READ ( INTRMN, * ) N + IF ( N.LT.0 ) THEN +C +C The specified value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be larger than zero.'' )' ) + GO TO 20 + ELSE IF ( N.GT.NMAX ) THEN +C +C The specified value of n is not acceptable. +C + WRITE( OUTRMN, '(/'' n should be less than or equal to '', + $ I5 )' ) NMAX + GO TO 20 + END IF +C + RETURN +C +C *** Last line of IB01OY *** + END diff --git a/mex/sources/libslicot/IB01PD.f b/mex/sources/libslicot/IB01PD.f new file mode 100644 index 000000000..45c3e0f11 --- /dev/null +++ b/mex/sources/libslicot/IB01PD.f @@ -0,0 +1,1232 @@ + SUBROUTINE IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, + $ LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, + $ RY, LDRY, S, LDS, O, LDO, TOL, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the matrices A, C, B, and D of a linear time-invariant +C (LTI) state space model, using the singular value decomposition +C information provided by other routines. Optionally, the system and +C noise covariance matrices, needed for the Kalman gain, are also +C determined. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C JOB CHARACTER*1 +C Specifies which matrices should be computed, as follows: +C = 'A': compute all system matrices, A, B, C, and D; +C = 'C': compute the matrices A and C only; +C = 'B': compute the matrix B only; +C = 'D': compute the matrices B and D only. +C +C JOBCV CHARACTER*1 +C Specifies whether or not the covariance matrices are to +C be computed, as follows: +C = 'C': the covariance matrices should be computed; +C = 'N': the covariance matrices should not be computed. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C Hankel matrices processed by other routines. NOBR > 1. +C +C N (input) INTEGER +C The order of the system. NOBR > N > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMPL (input) INTEGER +C If JOBCV = 'C', the total number of samples used for +C calculating the covariance matrices. +C NSMPL >= 2*(M+L)*NOBR. +C This parameter is not meaningful if JOBCV = 'N'. +C +C R (input/workspace) DOUBLE PRECISION array, dimension +C ( LDR,2*(M+L)*NOBR ) +C On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR part +C of this array must contain the relevant data for the MOESP +C or N4SID algorithms, as constructed by SLICOT Library +C routines IB01AD or IB01ND. Let R_ij, i,j = 1:4, be the +C ij submatrix of R (denoted S in IB01AD and IB01ND), +C partitioned by M*NOBR, L*NOBR, M*NOBR, and L*NOBR +C rows and columns. The submatrix R_22 contains the matrix +C of left singular vectors used. Also needed, for +C METH = 'N' or JOBCV = 'C', are the submatrices R_11, +C R_14 : R_44, and, for METH = 'M' and JOB <> 'C', the +C submatrices R_31 and R_12, containing the processed +C matrices R_1c and R_2c, respectively, as returned by +C SLICOT Library routines IB01AD or IB01ND. +C Moreover, if METH = 'N' and JOB = 'A' or 'C', the +C block-row R_41 : R_43 must contain the transpose of the +C block-column R_14 : R_34 as returned by SLICOT Library +C routines IB01AD or IB01ND. +C The remaining part of R is used as workspace. +C On exit, part of this array is overwritten. Specifically, +C if METH = 'M', R_22 and R_31 are overwritten if +C JOB = 'B' or 'D', and R_12, R_22, R_14 : R_34, +C and possibly R_11 are overwritten if JOBCV = 'C'; +C if METH = 'N', all needed submatrices are overwritten. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= 2*(M+L)*NOBR. +C +C A (input or output) DOUBLE PRECISION array, dimension +C (LDA,N) +C On entry, if METH = 'N' and JOB = 'B' or 'D', the +C leading N-by-N part of this array must contain the system +C state matrix. +C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), +C this array need not be set on input. +C On exit, if JOB = 'A' or 'C' and INFO = 0, the +C leading N-by-N part of this array contains the system +C state matrix. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= N, if JOB = 'A' or 'C', or METH = 'N' and +C JOB = 'B' or 'D'; +C LDA >= 1, otherwise. +C +C C (input or output) DOUBLE PRECISION array, dimension +C (LDC,N) +C On entry, if METH = 'N' and JOB = 'B' or 'D', the +C leading L-by-N part of this array must contain the system +C output matrix. +C If METH = 'M' or (METH = 'N' and JOB = 'A' or 'C'), +C this array need not be set on input. +C On exit, if JOB = 'A' or 'C' and INFO = 0, or +C INFO = 3 (or INFO >= 0, for METH = 'M'), the leading +C L-by-N part of this array contains the system output +C matrix. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= L, if JOB = 'A' or 'C', or METH = 'N' and +C JOB = 'B' or 'D'; +C LDC >= 1, otherwise. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If M > 0, JOB = 'A', 'B', or 'D' and INFO = 0, the +C leading N-by-M part of this array contains the system +C input matrix. If M = 0 or JOB = 'C', this array is +C not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if M > 0 and JOB = 'A', 'B', or 'D'; +C LDB >= 1, if M = 0 or JOB = 'C'. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C If M > 0, JOB = 'A' or 'D' and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix. If M = 0 or JOB = 'C' or 'B', this array is +C not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'A' or 'D'; +C LDD >= 1, if M = 0 or JOB = 'C' or 'B'. +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C If JOBCV = 'C', the leading N-by-N part of this array +C contains the positive semidefinite state covariance matrix +C to be used as state weighting matrix when computing the +C Kalman gain. +C This parameter is not referenced if JOBCV = 'N'. +C +C LDQ INTEGER +C The leading dimension of the array Q. +C LDQ >= N, if JOBCV = 'C'; +C LDQ >= 1, if JOBCV = 'N'. +C +C RY (output) DOUBLE PRECISION array, dimension (LDRY,L) +C If JOBCV = 'C', the leading L-by-L part of this array +C contains the positive (semi)definite output covariance +C matrix to be used as output weighting matrix when +C computing the Kalman gain. +C This parameter is not referenced if JOBCV = 'N'. +C +C LDRY INTEGER +C The leading dimension of the array RY. +C LDRY >= L, if JOBCV = 'C'; +C LDRY >= 1, if JOBCV = 'N'. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,L) +C If JOBCV = 'C', the leading N-by-L part of this array +C contains the state-output cross-covariance matrix to be +C used as cross-weighting matrix when computing the Kalman +C gain. +C This parameter is not referenced if JOBCV = 'N'. +C +C LDS INTEGER +C The leading dimension of the array S. +C LDS >= N, if JOBCV = 'C'; +C LDS >= 1, if JOBCV = 'N'. +C +C O (output) DOUBLE PRECISION array, dimension ( LDO,N ) +C If METH = 'M' and JOBCV = 'C', or METH = 'N', +C the leading L*NOBR-by-N part of this array contains +C the estimated extended observability matrix, i.e., the +C first N columns of the relevant singular vectors. +C If METH = 'M' and JOBCV = 'N', this array is not +C referenced. +C +C LDO INTEGER +C The leading dimension of the array O. +C LDO >= L*NOBR, if JOBCV = 'C' or METH = 'N'; +C LDO >= 1, otherwise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = N, if METH = 'M' and M = 0 +C or JOB = 'C' and JOBCV = 'N'; +C LIWORK = M*NOBR+N, if METH = 'M', JOB = 'C', +C and JOBCV = 'C'; +C LIWORK = max(L*NOBR,M*NOBR), if METH = 'M', JOB <> 'C', +C and JOBCV = 'N'; +C LIWORK = max(L*NOBR,M*NOBR+N), if METH = 'M', JOB <> 'C', +C and JOBCV = 'C'; +C LIWORK = max(M*NOBR+N,M*(N+L)), if METH = 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3), DWORK(4), and +C DWORK(5) contain the reciprocal condition numbers of the +C triangular factors of the matrices, defined in the code, +C GaL (GaL = Un(1:(s-1)*L,1:n)), R_1c (if METH = 'M'), +C M (if JOBCV = 'C' or METH = 'N'), and Q or T (see +C SLICOT Library routines IB01PY or IB01PX), respectively. +C If METH = 'N', DWORK(3) is set to one without any +C calculations. Similarly, if METH = 'M' and JOBCV = 'N', +C DWORK(4) is set to one. If M = 0 or JOB = 'C', +C DWORK(3) and DWORK(5) are set to one. +C On exit, if INFO = -30, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( LDW1,LDW2 ), where, if METH = 'M', +C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ), +C if JOB = 'C' or JOB = 'A' and M = 0; +C LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N, +C (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+ +C max( L+M*NOBR, L*NOBR + +C max( 3*L*NOBR+1, M ) ) ) +C if M > 0 and JOB = 'A', 'B', or 'D'; +C LDW2 >= 0, if JOBCV = 'N'; +C LDW2 >= max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L), +C 4*(M*NOBR+N)+1, M*NOBR+2*N+L ), +C if JOBCV = 'C', +C where Aw = N+N*N, if M = 0 or JOB = 'C'; +C Aw = 0, otherwise; +C and, if METH = 'N', +C LDW1 >= max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, N+4*(M*NOBR+N)+1, +C M*NOBR+3*N+L ); +C LDW2 >= 0, if M = 0 or JOB = 'C'; +C LDW2 >= M*NOBR*(N+L)*(M*(N+L)+1)+ +C max( (N+L)**2, 4*M*(N+L)+1 ), +C if M > 0 and JOB = 'A', 'B', or 'D'. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: a least squares problem to be solved has a +C rank-deficient coefficient matrix; +C = 5: the computed covariance matrices are too small. +C The problem seems to be a deterministic one. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge; +C = 3: a singular upper triangular matrix was found. +C +C METHOD +C +C In the MOESP approach, the matrices A and C are first +C computed from an estimated extended observability matrix [1], +C and then, the matrices B and D are obtained by solving an +C extended linear system in a least squares sense. +C In the N4SID approach, besides the estimated extended +C observability matrix, the solutions of two least squares problems +C are used to build another least squares problem, whose solution +C is needed to compute the system matrices A, C, B, and D. The +C solutions of the two least squares problems are also optionally +C used by both approaches to find the covariance matrices. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error state- +C space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Van Overschee, P., and De Moor, B. +C N4SID: Two Subspace Algorithms for the Identification +C of Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [3] Van Overschee, P. +C Subspace Identification : Theory - Implementation - +C Applications. +C Ph. D. Thesis, Department of Electrical Engineering, +C Katholieke Universiteit Leuven, Belgium, Feb. 1995. +C +C [4] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C FURTHER COMMENTS +C +C In some applications, it is useful to compute the system matrices +C using two calls to this routine, the first one with JOB = 'C', +C and the second one with JOB = 'B' or 'D'. This is slightly less +C efficient than using a single call with JOB = 'A', because some +C calculations are repeated. If METH = 'N', all the calculations +C at the first call are performed again at the second call; +C moreover, it is required to save the needed submatrices of R +C before the first call and restore them before the second call. +C If the covariance matrices are desired, JOBCV should be set +C to 'C' at the second call. If B and D are both needed, they +C should be computed at once. +C It is possible to compute the matrices A and C using the MOESP +C algorithm (METH = 'M'), and the matrices B and D using the N4SID +C algorithm (METH = 'N'). This combination could be slightly more +C efficient than N4SID algorithm alone and it could be more accurate +C than MOESP algorithm. No saving/restoring is needed in such a +C combination, provided JOBCV is set to 'N' at the first call. +C Recommended usage: either one call with JOB = 'A', or +C first call with METH = 'M', JOB = 'C', JOBCV = 'N', +C second call with METH = 'M', JOB = 'D', JOBCV = 'C', or +C first call with METH = 'M', JOB = 'C', JOBCV = 'N', +C second call with METH = 'N', JOB = 'D', JOBCV = 'C'. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999. +C +C REVISIONS +C +C March 2000, Feb. 2001, Sep. 2001, March 2005. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDO, LDQ, + $ LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL + CHARACTER JOB, JOBCV, METH +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), O(LDO, *), Q(LDQ, *), R(LDR, *), + $ RY(LDRY, *), S(LDS, *) + INTEGER IWORK( * ) +C .. Local Scalars .. + DOUBLE PRECISION EPS, RCOND1, RCOND2, RCOND3, RCOND4, RNRM, + $ SVLMAX, THRESH, TOLL, TOLL1 + INTEGER I, IAW, ID, IERR, IGAL, IHOUS, ISV, ITAU, + $ ITAU1, ITAU2, IU, IUN2, IWARNL, IX, JWORK, + $ LDUN2, LDUNN, LDW, LMMNOB, LMMNOL, LMNOBR, + $ LNOBR, LNOBRN, MAXWRK, MINWRK, MNOBR, MNOBRN, + $ N2, NCOL, NN, NPL, NR, NR2, NR3, NR4, NR4MN, + $ NR4PL, NROW, RANK, RANK11, RANKM + CHARACTER FACT, JOBP, JOBPY + LOGICAL FULLR, MOESP, N4SID, SHIFT, WITHAL, WITHB, + $ WITHC, WITHCO, WITHD +C .. Local Array .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, + $ DSYRK, DTRCON, DTRSM, DTRTRS, IB01PX, IB01PY, + $ MA02AD, MA02ED, MB02QY, MB02UD, MB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + WITHAL = LSAME( JOB, 'A' ) + WITHC = LSAME( JOB, 'C' ) .OR. WITHAL + WITHD = LSAME( JOB, 'D' ) .OR. WITHAL + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + WITHCO = LSAME( JOBCV, 'C' ) + MNOBR = M*NOBR + LNOBR = L*NOBR + LMNOBR = LNOBR + MNOBR + LMMNOB = LNOBR + 2*MNOBR + MNOBRN = MNOBR + N + LNOBRN = LNOBR - N + LDUN2 = LNOBR - L + LDUNN = LDUN2*N + LMMNOL = LMMNOB + L + NR = LMNOBR + LMNOBR + NPL = N + L + N2 = N + N + NN = N*N + MINWRK = 1 + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN + INFO = -2 + ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCV, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( NOBR.LE.1 ) THEN + INFO = -4 + ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( L.LE.0 ) THEN + INFO = -7 + ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN + INFO = -8 + ELSE IF( LDR.LT.NR ) THEN + INFO = -10 + ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) + $ .AND. LDA.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. N4SID ) ) + $ .AND. LDC.LT.L ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.N .AND. M.GT.0 ) ) + $ THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -18 + ELSE IF( LDQ.LT.1 .OR. ( WITHCO .AND. LDQ.LT.N ) ) THEN + INFO = -20 + ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN + INFO = -22 + ELSE IF( LDS.LT.1 .OR. ( WITHCO .AND. LDS.LT.N ) ) THEN + INFO = -24 + ELSE IF( LDO.LT.1 .OR. ( ( WITHCO .OR. N4SID ) .AND. + $ LDO.LT.LNOBR ) ) THEN + INFO = -26 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IAW = 0 + MINWRK = LDUNN + 4*N + MAXWRK = LDUNN + N + N*ILAENV( 1, 'DGEQRF', ' ', LDUN2, N, -1, + $ -1 ) + IF( MOESP ) THEN + ID = 0 + IF( WITHC ) THEN + MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N ) + MAXWRK = MAX( MAXWRK, 2*LDUNN + N + N*ILAENV( 1, + $ 'DORMQR', 'LT', LDUN2, N, N, -1 ) ) + END IF + ELSE + ID = N + END IF +C + IF( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN + MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N ) + IF ( MOESP ) + $ MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N + + $ MAX( L + MNOBR, LNOBR + + $ MAX( 3*LNOBR + 1, M ) ) ) + ELSE + IF( MOESP ) + $ IAW = N + NN + END IF +C + IF( N4SID .OR. WITHCO ) THEN + MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ), + $ ID + 4*MNOBRN+1, ID + MNOBRN + NPL ) + MAXWRK = MAX( MAXWRK, LDUNN + IAW + N2 + + $ MAX( N*ILAENV( 1, 'DGEQRF', ' ', LNOBR, N, -1, + $ -1 ), LMMNOB* + $ ILAENV( 1, 'DORMQR', 'LT', LNOBR, + $ LMMNOB, N, -1 ), LMMNOL* + $ ILAENV( 1, 'DORMQR', 'LT', LDUN2, + $ LMMNOL, N, -1 ) ), + $ ID + N + N*ILAENV( 1, 'DGEQRF', ' ', LMNOBR, + $ N, -1, -1 ), + $ ID + N + NPL*ILAENV( 1, 'DORMQR', 'LT', + $ LMNOBR, NPL, N, -1 ) ) + IF( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) + $ MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) + + $ MAX( NPL**2, 4*M*NPL + 1 ) ) + END IF + MAXWRK = MAX( MINWRK, MAXWRK ) +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -30 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01PD', -INFO ) + RETURN + END IF +C + NR2 = MNOBR + 1 + NR3 = LMNOBR + 1 + NR4 = LMMNOB + 1 +C +C Set the precision parameters. A threshold value EPS**(2/3) is +C used for deciding to use pivoting or not, where EPS is the +C relative machine precision (see LAPACK Library routine DLAMCH). +C + EPS = DLAMCH( 'Precision' ) + THRESH = EPS**( TWO/THREE ) + SVLMAX = ZERO + RCOND4 = ONE +C +C Let Un be the matrix of left singular vectors (stored in R_22). +C Copy un1 = GaL = Un(1:(s-1)*L,1:n) in the workspace. +C + IGAL = 1 + CALL DLACPY( 'Full', LDUN2, N, R(NR2,NR2), LDR, DWORK(IGAL), + $ LDUN2 ) +C +C Factor un1 = Q1*[r1' 0]' (' means transposition). +C Workspace: need L*(NOBR-1)*N+2*N, +C prefer L*(NOBR-1)*N+N+N*NB. +C + ITAU1 = IGAL + LDUNN + JWORK = ITAU1 + N + LDW = JWORK + CALL DGEQRF( LDUN2, N, DWORK(IGAL), LDUN2, DWORK(ITAU1), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Compute the reciprocal of the condition number of r1. +C Workspace: need L*(NOBR-1)*N+4*N. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', N, DWORK(IGAL), LDUN2, + $ RCOND1, DWORK(JWORK), IWORK, INFO ) +C + TOLL1 = TOL + IF( TOLL1.LE.ZERO ) + $ TOLL1 = NN*EPS +C + IF ( ( M.GT.0 .AND. WITHB ) .OR. N4SID ) THEN + JOBP = 'P' + IF ( WITHAL ) THEN + JOBPY = 'D' + ELSE + JOBPY = JOB + END IF + ELSE + JOBP = 'N' + END IF +C + IF ( MOESP ) THEN + NCOL = 0 + IUN2 = JWORK + IF ( WITHC ) THEN +C +C Set C = Un(1:L,1:n) and then compute the system matrix A. +C +C Set un2 = Un(L+1:L*s,1:n) in DWORK(IUN2). +C Workspace: need 2*L*(NOBR-1)*N+N. +C + CALL DLACPY( 'Full', L, N, R(NR2,NR2), LDR, C, LDC ) + CALL DLACPY( 'Full', LDUN2, N, R(NR2+L,NR2), LDR, + $ DWORK(IUN2), LDUN2 ) +C +C Note that un1 has already been factored as +C un1 = Q1*[r1' 0]' and usually (generically, assuming +C observability) has full column rank. +C Update un2 <-- Q1'*un2 in DWORK(IUN2) and save its +C first n rows in A. +C Workspace: need 2*L*(NOBR-1)*N+2*N; +C prefer 2*L*(NOBR-1)*N+N+N*NB. +C + JWORK = IUN2 + LDUNN + CALL DORMQR( 'Left', 'Transpose', LDUN2, N, N, DWORK(IGAL), + $ LDUN2, DWORK(ITAU1), DWORK(IUN2), LDUN2, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + CALL DLACPY( 'Full', N, N, DWORK(IUN2), LDUN2, A, LDA ) + NCOL = N + JWORK = IUN2 + END IF +C + IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN +C +C The triangular factor r1 is considered to be of full rank. +C Solve for A (if requested), r1*A = un2(1:n,:) in A. +C + IF ( WITHC ) THEN + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, N, + $ DWORK(IGAL), LDUN2, A, LDA, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + END IF + RANK = N + ELSE +C +C Rank-deficient triangular factor r1. Use SVD of r1, +C r1 = U*S*V', also for computing A (if requested) from +C r1*A = un2(1:n,:). Matrix U is computed in DWORK(IU), +C and V' overwrites r1. If B is requested, the +C pseudoinverse of r1 and then of GaL are also computed +C in R(NR3,NR2). +C Workspace: need c*L*(NOBR-1)*N+N*N+7*N, +C where c = 1 if B and D are not needed, +C c = 2 if B and D are needed; +C prefer larger. +C + IU = IUN2 + ISV = IU + NN + JWORK = ISV + N + IF ( M.GT.0 .AND. WITHB ) THEN +C +C Save the elementary reflectors used for computing r1, +C if B, D are needed. +C Workspace: need 2*L*(NOBR-1)*N+2*N+N*N. +C + IHOUS = JWORK + JWORK = IHOUS + LDUNN + CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, + $ DWORK(IHOUS), LDUN2 ) + ELSE + IHOUS = IGAL + END IF +C + CALL MB02UD( 'Not factored', 'Left', 'NoTranspose', JOBP, N, + $ NCOL, ONE, TOLL1, RANK, DWORK(IGAL), LDUN2, + $ DWORK(IU), N, DWORK(ISV), A, LDA, R(NR3,NR2), + $ LDR, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + IF ( RANK.EQ.0 ) THEN + JOBP = 'N' + ELSE IF ( M.GT.0 .AND. WITHB ) THEN +C +C Compute pinv(GaL) in R(NR3,NR2) if B, D are needed. +C Workspace: need 2*L*(NOBR-1)*N+N*N+3*N; +C prefer 2*L*(NOBR-1)*N+N*N+2*N+N*NB. +C + CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, + $ R(NR3,NR2+N), LDR ) + CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, + $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), + $ R(NR3,NR2), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( WITHCO ) THEN +C +C Save pinv(GaL) in DWORK(IGAL). +C + CALL DLACPY( 'Full', N, LDUN2, R(NR3,NR2), LDR, + $ DWORK(IGAL), N ) + END IF + JWORK = IUN2 + END IF + LDW = JWORK + END IF +C + IF ( M.GT.0 .AND. WITHB ) THEN +C +C Computation of B and D. +C +C Compute the reciprocal of the condition number of R_1c. +C Workspace: need L*(NOBR-1)*N+N+3*M*NOBR. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R(NR3,1), + $ LDR, RCOND2, DWORK(JWORK), IWORK, IERR ) +C + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = MNOBR*MNOBR*EPS +C +C Compute the right hand side and solve for K (in R_23), +C K*R_1c' = u2'*R_2c', +C where u2 = Un(:,n+1:L*s), and K is (Ls-n) x ms. +C + CALL DGEMM( 'Transpose', 'Transpose', LNOBRN, MNOBR, LNOBR, + $ ONE, R(NR2,NR2+N), LDR, R(1,NR2), LDR, ZERO, + $ R(NR2,NR3), LDR ) +C + IF ( RCOND2.GT.MAX( TOLL, THRESH ) ) THEN +C +C The triangular factor R_1c is considered to be of full +C rank. Solve for K, K*R_1c' = u2'*R_2c'. +C + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'Non-unit', + $ LNOBRN, MNOBR, ONE, R(NR3,1), LDR, + $ R(NR2,NR3), LDR ) + ELSE +C +C Rank-deficient triangular factor R_1c. Use SVD of R_1c +C for computing K from K*R_1c' = u2'*R_2c', where +C R_1c = U1*S1*V1'. Matrix U1 is computed in R_33, +C and V1' overwrites R_1c. +C Workspace: need L*(NOBR-1)*N+N+6*M*NOBR; +C prefer larger. +C + ISV = LDW + JWORK = ISV + MNOBR + CALL MB02UD( 'Not factored', 'Right', 'Transpose', + $ 'No pinv', LNOBRN, MNOBR, ONE, TOLL, RANK11, + $ R(NR3,1), LDR, R(NR3,NR3), LDR, DWORK(ISV), + $ R(NR2,NR3), LDR, DWORK(JWORK), 1, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = LDW + END IF +C +C Compute the triangular factor of the structured matrix Q +C and apply the transformations to the matrix Kexpand, where +C Q and Kexpand are defined in SLICOT Library routine +C IB01PY. Compute also the matrices B, D. +C Workspace: need L*(NOBR-1)*N+N+max(L+M*NOBR,L*NOBR+ +C max(3*L*NOBR+1,M)); +C prefer larger. +C + IF ( WITHCO ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) + CALL IB01PY( METH, JOBPY, NOBR, N, M, L, RANK, R(NR2,NR2), + $ LDR, DWORK(IGAL), LDUN2, DWORK(ITAU1), + $ R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR4,NR2), + $ LDR, R(NR4,NR3), LDR, B, LDB, D, LDD, TOL, + $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARN, + $ INFO ) + IF ( INFO.NE.0 ) + $ RETURN + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + RCOND4 = DWORK(JWORK+1) + IF ( WITHCO ) + $ CALL DLACPY( 'Full', LNOBR, N, O, LDO, R(NR2,1), LDR ) +C + ELSE + RCOND2 = ONE + END IF +C + IF ( .NOT.WITHCO ) THEN + RCOND3 = ONE + GO TO 30 + END IF + ELSE +C +C For N4SID, set RCOND2 to one. +C + RCOND2 = ONE + END IF +C +C If needed, save the first n columns, representing Gam, of the +C matrix of left singular vectors, Un, in R_21 and in O. +C + IF ( N4SID .OR. ( WITHC .AND. .NOT.WITHAL ) ) THEN + IF ( M.GT.0 ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, R(NR2,1), + $ LDR ) + CALL DLACPY( 'Full', LNOBR, N, R(NR2,NR2), LDR, O, LDO ) + END IF +C +C Computations for covariance matrices, and system matrices (N4SID). +C Solve the least squares problems Gam*Y = R4(1:L*s,1:(2*m+L)*s), +C GaL*X = R4(L+1:L*s,:), where +C GaL = Gam(1:L*(s-1),:), Gam has full column rank, and +C R4 = [ R_14' R_24' R_34' R_44L' ], R_44L = R_44(1:L,:), as +C returned by SLICOT Library routine IB01ND. +C First, find the QR factorization of Gam, Gam = Q*R. +C Workspace: need L*(NOBR-1)*N+Aw+3*N; +C prefer L*(NOBR-1)*N+Aw+2*N+N*NB, where +C Aw = N+N*N, if (M = 0 or JOB = 'C'), rank(r1) < N, +C and METH = 'M'; +C Aw = 0, otherwise. +C + ITAU2 = LDW + JWORK = ITAU2 + N + CALL DGEQRF( LNOBR, N, R(NR2,1), LDR, DWORK(ITAU2), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C For METH = 'M' or when JOB = 'B' or 'D', transpose +C [ R_14' R_24' R_34' ]' in the last block-row of R, obtaining Z, +C and for METH = 'N' and JOB = 'A' or 'C', use the matrix Z +C already available in the last block-row of R, and then apply +C the transformations, Z <-- Q'*Z. +C Workspace: need L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR; +C prefer L*(NOBR-1)*N+Aw+2*N+(2*M+L)*NOBR*NB. +C + IF ( MOESP .OR. ( WITHB .AND. .NOT. WITHAL ) ) + $ CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1), + $ LDR ) + CALL DORMQR( 'Left', 'Transpose', LNOBR, LMMNOB, N, R(NR2,1), LDR, + $ DWORK(ITAU2), R(NR4,1), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Solve for Y, RY = Z in Z and save the transpose of the +C solution Y in the second block-column of R. +C + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOB, + $ R(NR2,1), LDR, R(NR4,1), LDR, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + CALL MA02AD( 'Full', N, LMMNOB, R(NR4,1), LDR, R(1,NR2), LDR ) + NR4MN = NR4 - N + NR4PL = NR4 + L + NROW = LMMNOL +C +C SHIFT is .TRUE. if some columns of R_14 : R_44L should be +C shifted to the right, to avoid overwriting useful information. +C + SHIFT = M.EQ.0 .AND. LNOBR.LT.N2 +C + IF ( RCOND1.GT.MAX( TOLL1, THRESH ) ) THEN +C +C The triangular factor r1 of GaL (GaL = Q1*r1) is +C considered to be of full rank. +C +C Transpose [ R_14' R_24' R_34' R_44L' ]'(:,L+1:L*s) in the +C last block-row of R (beginning with the (L+1)-th row), +C obtaining Z1, and then apply the transformations, +C Z1 <-- Q1'*Z1. +C Workspace: need L*(NOBR-1)*N+Aw+2*N+ (2*M+L)*NOBR + L; +C prefer L*(NOBR-1)*N+Aw+2*N+((2*M+L)*NOBR + L)*NB. +C + CALL MA02AD( 'Full', LMMNOL, LDUN2, R(1,NR4PL), LDR, + $ R(NR4PL,1), LDR ) + CALL DORMQR( 'Left', 'Transpose', LDUN2, LMMNOL, N, + $ DWORK(IGAL), LDUN2, DWORK(ITAU1), R(NR4PL,1), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Solve for X, r1*X = Z1 in Z1, and copy the transpose of X +C into the last part of the third block-column of R. +C + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, LMMNOL, + $ DWORK(IGAL), LDUN2, R(NR4PL,1), LDR, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF +C + IF ( SHIFT ) THEN + NR4MN = NR4 +C + DO 10 I = L - 1, 0, -1 + CALL DCOPY( LMMNOL, R(1,NR4+I), 1, R(1,NR4+N+I), 1 ) + 10 CONTINUE +C + END IF + CALL MA02AD( 'Full', N, LMMNOL, R(NR4PL,1), LDR, R(1,NR4MN), + $ LDR ) + NROW = 0 + END IF +C + IF ( N4SID .OR. NROW.GT.0 ) THEN +C +C METH = 'N' or rank-deficient triangular factor r1. +C For METH = 'N', use SVD of r1, r1 = U*S*V', for computing +C X' from X'*GaL' = Z1', if rank(r1) < N. Matrix U is +C computed in DWORK(IU) and V' overwrites r1. Then, the +C pseudoinverse of GaL is determined in R(NR4+L,NR2). +C For METH = 'M', the pseudoinverse of GaL is already available +C if M > 0 and B is requested; otherwise, the SVD of r1 is +C available in DWORK(IU), DWORK(ISV), and DWORK(IGAL). +C Workspace for N4SID: need 2*L*(NOBR-1)*N+N*N+8*N; +C prefer larger. +C + IF ( MOESP ) THEN + FACT = 'F' + IF ( M.GT.0 .AND. WITHB ) + $ CALL DLACPY( 'Full', N, LDUN2, DWORK(IGAL), N, + $ R(NR4PL,NR2), LDR ) + ELSE +C +C Save the elementary reflectors used for computing r1. +C + IHOUS = JWORK + CALL DLACPY( 'Lower', LDUN2, N, DWORK(IGAL), LDUN2, + $ DWORK(IHOUS), LDUN2 ) + FACT = 'N' + IU = IHOUS + LDUNN + ISV = IU + NN + JWORK = ISV + N + END IF +C + CALL MB02UD( FACT, 'Right', 'Transpose', JOBP, NROW, N, ONE, + $ TOLL1, RANK, DWORK(IGAL), LDUN2, DWORK(IU), N, + $ DWORK(ISV), R(1,NR4PL), LDR, R(NR4PL,NR2), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( NROW.GT.0 ) THEN + IF ( SHIFT ) THEN + NR4MN = NR4 + CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4), LDR, + $ R(1,NR4-L), LDR ) + CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, + $ R(1,NR4MN), LDR ) + CALL DLACPY( 'Full', LMMNOL, L, R(1,NR4-L), LDR, + $ R(1,NR4+N), LDR ) + ELSE + CALL DLACPY( 'Full', LMMNOL, N, R(1,NR4PL), LDR, + $ R(1,NR4MN), LDR ) + END IF + END IF +C + IF ( N4SID ) THEN + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Compute pinv(GaL) in R(NR4+L,NR2). +C Workspace: need 2*L*(NOBR-1)*N+3*N; +C prefer 2*L*(NOBR-1)*N+2*N+N*NB. +C + JWORK = IU + CALL DLASET( 'Full', N, LDUN2-N, ZERO, ZERO, R(NR4PL,NR2+N), + $ LDR ) + CALL DORMQR( 'Right', 'Transpose', N, LDUN2, N, + $ DWORK(IHOUS), LDUN2, DWORK(ITAU1), + $ R(NR4PL,NR2), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF + END IF +C +C For METH = 'N', find part of the solution (corresponding to A +C and C) and, optionally, for both METH = 'M', or METH = 'N', +C find the residual of the least squares problem that gives the +C covariances, M*V = N, where +C ( R_11 ) +C M = ( Y' ), N = ( X' R4'(:,1:L) ), V = V(n+m*s, n+L), +C ( 0 0 ) +C with M((2*m+L)*s+L, n+m*s), N((2*m+L)*s+L, n+L), R4' being +C stored in the last block-column of R. The last L rows of M +C are not explicitly considered. Note that, for efficiency, the +C last m*s columns of M are in the first positions of arrray R. +C This permutation does not affect the residual, only the +C solution. (The solution is not needed for METH = 'M'.) +C Note that R_11 corresponds to the future outputs for both +C METH = 'M', or METH = 'N' approaches. (For METH = 'N', the +C first two block-columns have been interchanged.) +C For METH = 'N', A and C are obtained as follows: +C [ A' C' ] = V(m*s+1:m*s+n,:). +C +C First, find the QR factorization of Y'(m*s+1:(2*m+L)*s,:) +C and apply the transformations to the corresponding part of N. +C Compress the workspace for N4SID by moving the scalar reflectors +C corresponding to Q. +C Workspace: need d*N+2*N; +C prefer d*N+N+N*NB; +C where d = 0, for MOESP, and d = 1, for N4SID. +C + IF ( MOESP ) THEN + ITAU = 1 + ELSE + CALL DCOPY( N, DWORK(ITAU2), 1, DWORK, 1 ) + ITAU = N + 1 + END IF +C + JWORK = ITAU + N + CALL DGEQRF( LMNOBR, N, R(NR2,NR2), LDR, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Workspace: need d*N+N+(N+L); +C prefer d*N+N+(N+L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', LMNOBR, NPL, N, R(NR2,NR2), LDR, + $ DWORK(ITAU), R(NR2,NR4MN), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C + CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, R(NR4+1,NR4), LDR ) +C +C Now, matrix M with permuted block-columns has been +C triangularized. +C Compute the reciprocal of the condition number of its +C triangular factor in R(1:m*s+n,1:m*s+n). +C Workspace: need d*N+3*(M*NOBR+N). +C + JWORK = ITAU + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBRN, R, LDR, RCOND3, + $ DWORK(JWORK), IWORK, INFO ) +C + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = MNOBRN*MNOBRN*EPS + IF ( RCOND3.GT.MAX( TOLL, THRESH ) ) THEN +C +C The triangular factor is considered to be of full rank. +C Solve for V(m*s+1:m*s+n,:), giving [ A' C' ]. +C + FULLR = .TRUE. + RANKM = MNOBRN + IF ( N4SID ) + $ CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, + $ NPL, ONE, R(NR2,NR2), LDR, R(NR2,NR4MN), LDR ) + ELSE + FULLR = .FALSE. +C +C Use QR factorization (with pivoting). For METH = 'N', save +C (and then restore) information about the QR factorization of +C Gam, for later use. Note that R_11 could be modified by +C MB03OD, but the corresponding part of N is also modified +C accordingly. +C Workspace: need d*N+4*(M*NOBR+N)+1; +C prefer d*N+3*(M*NOBR+N)+(M*NOBR+N+1)*NB. +C + DO 20 I = 1, MNOBRN + IWORK(I) = 0 + 20 CONTINUE +C + IF ( N4SID .AND. ( M.GT.0 .AND. WITHB ) ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR2,1), LDR, R(NR4,1), + $ LDR ) + JWORK = ITAU + MNOBRN + CALL DLASET( 'Lower', MNOBRN-1, MNOBRN, ZERO, ZERO, R(2,1), + $ LDR ) + CALL MB03OD( 'QR', MNOBRN, MNOBRN, R, LDR, IWORK, TOLL, + $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need d*N+M*NOBR+N+N+L; +C prefer d*N+M*NOBR+N+(N+L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', MNOBRN, NPL, MNOBRN, + $ R, LDR, DWORK(ITAU), R(1,NR4MN), LDR, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C + IF ( WITHCO ) THEN +C +C The residual (transposed) of the least squares solution +C (multiplied by a matrix with orthogonal columns) is stored +C in the rows RANKM+1:(2*m+L)*s+L of V, and it should be +C squared-up for getting the covariance matrices. (Generically, +C RANKM = m*s+n.) +C + RNRM = ONE/DBLE( NSMPL ) + IF ( MOESP ) THEN + CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, + $ R(RANKM+1,NR4MN), LDR, ZERO, R, LDR ) + CALL DLACPY( 'Upper', N, N, R, LDR, Q, LDQ ) + CALL DLACPY( 'Full', N, L, R(1,N+1), LDR, S, LDS ) + CALL DLACPY( 'Upper', L, L, R(N+1,N+1), LDR, RY, LDRY ) + ELSE + CALL DSYRK( 'Upper', 'Transpose', NPL, LMMNOL-RANKM, RNRM, + $ R(RANKM+1,NR4MN), LDR, ZERO, DWORK(JWORK), NPL ) + CALL DLACPY( 'Upper', N, N, DWORK(JWORK), NPL, Q, LDQ ) + CALL DLACPY( 'Full', N, L, DWORK(JWORK+N*NPL), NPL, S, + $ LDS ) + CALL DLACPY( 'Upper', L, L, DWORK(JWORK+N*(NPL+1)), NPL, RY, + $ LDRY ) + END IF + CALL MA02ED( 'Upper', N, Q, LDQ ) + CALL MA02ED( 'Upper', L, RY, LDRY ) +C +C Check the magnitude of the residual. +C + RNRM = DLANGE( '1-norm', LMMNOL-RANKM, NPL, R(RANKM+1,NR4MN), + $ LDR, DWORK(JWORK) ) + IF ( RNRM.LT.THRESH ) + $ IWARN = 5 + END IF +C + IF ( N4SID ) THEN + IF ( .NOT.FULLR ) THEN + IWARN = 4 +C +C Compute part of the solution of the least squares problem, +C M*V = N, for the rank-deficient problem. +C Remark: this computation should not be performed before the +C symmetric updating operation above. +C Workspace: need M*NOBR+3*N+L; +C prefer larger. +C + CALL MB03OD( 'No QR', N, N, R(NR2,NR2), LDR, IWORK, TOLL1, + $ SVLMAX, DWORK(ITAU), RANKM, SVAL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + CALL MB02QY( N, N, NPL, RANKM, R(NR2,NR2), LDR, IWORK, + $ R(NR2,NR4MN), LDR, DWORK(ITAU+MNOBR), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU + IF ( M.GT.0 .AND. WITHB ) + $ CALL DLACPY( 'Full', LNOBR, N, R(NR4,1), LDR, R(NR2,1), + $ LDR ) + END IF +C + IF ( WITHC ) THEN +C +C Obtain A and C, noting that block-permutations have been +C implicitly used. +C + CALL MA02AD( 'Full', N, N, R(NR2,NR4MN), LDR, A, LDA ) + CALL MA02AD( 'Full', N, L, R(NR2,NR4MN+N), LDR, C, LDC ) + ELSE +C +C Use the given A and C. +C + CALL MA02AD( 'Full', N, N, A, LDA, R(NR2,NR4MN), LDR ) + CALL MA02AD( 'Full', L, N, C, LDC, R(NR2,NR4MN+N), LDR ) + END IF +C + IF ( M.GT.0 .AND. WITHB ) THEN +C +C Obtain B and D. +C First, compute the transpose of the matrix K as +C N(1:m*s,:) - M(1:m*s,m*s+1:m*s+n)*[A' C'], in the first +C m*s rows of R(1,NR4MN). +C + CALL DGEMM ( 'NoTranspose', 'NoTranspose', MNOBR, NPL, N, + $ -ONE, R(1,NR2), LDR, R(NR2,NR4MN), LDR, ONE, + $ R(1,NR4MN), LDR ) +C +C Denote M = pinv(GaL) and construct +C +C [ [ A ] -1 ] [ R ] +C and L = [ [ ] R 0 ] Q', where Gam = Q * [ ]. +C [ [ C ] ] [ 0 ] +C +C Then, solve the least squares problem. +C + CALL DLACPY( 'Full', N, N, A, LDA, R(NR2,NR4), LDR ) + CALL DLACPY( 'Full', L, N, C, LDC, R(NR2+N,NR4), LDR ) + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', + $ NPL, N, ONE, R(NR2,1), LDR, R(NR2,NR4), LDR ) + CALL DLASET( 'Full', NPL, LNOBRN, ZERO, ZERO, R(NR2,NR4+N), + $ LDR ) +C +C Workspace: need 2*N+L; prefer N + (N+L)*NB. +C + CALL DORMQR( 'Right', 'Transpose', NPL, LNOBR, N, R(NR2,1), + $ LDR, DWORK, R(NR2,NR4), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Obtain the matrix K by transposition, and find B and D. +C Workspace: need NOBR*(M*(N+L))**2+M*NOBR*(N+L)+ +C max((N+L)**2,4*M*(N+L)+1); +C prefer larger. +C + CALL MA02AD( 'Full', MNOBR, NPL, R(1,NR4MN), LDR, + $ R(NR2,NR3), LDR ) + IX = MNOBR*NPL**2*M + 1 + JWORK = IX + MNOBR*NPL + CALL IB01PX( JOBPY, NOBR, N, M, L, R, LDR, O, LDO, + $ R(NR2,NR4), LDR, R(NR4PL,NR2), LDR, R(NR2,NR3), + $ LDR, DWORK, MNOBR*NPL, DWORK(IX), B, LDB, D, + $ LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, + $ IWARNL, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + IWARN = MAX( IWARN, IWARNL ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + RCOND4 = DWORK(JWORK+1) +C + END IF + END IF +C + 30 CONTINUE +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C numbers in the next locations. +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND1 + DWORK(3) = RCOND2 + DWORK(4) = RCOND3 + DWORK(5) = RCOND4 + RETURN +C +C *** Last line of IB01PD *** + END diff --git a/mex/sources/libslicot/IB01PX.f b/mex/sources/libslicot/IB01PX.f new file mode 100644 index 000000000..cf19feb43 --- /dev/null +++ b/mex/sources/libslicot/IB01PX.f @@ -0,0 +1,474 @@ + SUBROUTINE IB01PX( JOB, NOBR, N, M, L, UF, LDUF, UN, LDUN, UL, + $ LDUL, PGAL, LDPGAL, K, LDK, R, LDR, X, B, LDB, + $ D, LDD, TOL, IWORK, DWORK, LDWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To build and solve the least squares problem T*X = Kv, and +C estimate the matrices B and D of a linear time-invariant (LTI) +C state space model, using the solution X, and the singular +C value decomposition information and other intermediate results, +C provided by other routines. +C +C The matrix T is computed as a sum of Kronecker products, +C +C T = T + kron(Uf(:,(i-1)*m+1:i*m),N_i), for i = 1 : s, +C +C (with T initialized by zero), where Uf is the triangular +C factor of the QR factorization of the future input part (see +C SLICOT Library routine IB01ND), N_i is given by the i-th block +C row of the matrix +C +C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ] [ I_L 0 ] +C [ Q_12 Q_13 ... Q_1,s-1 Q_1s 0 ] [ ] +C N = [ Q_13 Q_14 ... Q_1s 0 0 ] * [ ], +C [ : : : : : ] [ ] +C [ Q_1s 0 ... 0 0 0 ] [ 0 GaL ] +C +C and where +C +C [ -L_1|1 ] [ M_i-1 - L_1|i ] +C Q_11 = [ ], Q_1i = [ ], i = 2:s, +C [ I_L - L_2|1 ] [ -L_2|i ] +C +C are (n+L)-by-L matrices, and GaL is built from the first n +C relevant singular vectors, GaL = Un(1:L(s-1),1:n), computed +C by IB01ND. +C +C The vector Kv is vec(K), with the matrix K defined by +C +C K = [ K_1 K_2 K_3 ... K_s ], +C +C where K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. +C The given matrices are Uf, GaL, and +C +C [ L_1|1 ... L_1|s ] +C L = [ ], (n+L)-by-L*s, +C [ L_2|1 ... L_2|s ] +C +C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and +C K, (n+L)-by-m*s. +C +C Matrix M is the pseudoinverse of the matrix GaL, computed by +C SLICOT Library routine IB01PD. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies which of the matrices B and D should be +C computed, as follows: +C = 'B': compute the matrix B, but not the matrix D; +C = 'D': compute both matrices B and D. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C Hankel matrices processed by other routines. NOBR > 1. +C +C N (input) INTEGER +C The order of the system. NOBR > N > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C UF (input/output) DOUBLE PRECISION array, dimension +C ( LDUF,M*NOBR ) +C On entry, the leading M*NOBR-by-M*NOBR upper triangular +C part of this array must contain the upper triangular +C factor of the QR factorization of the future input part, +C as computed by SLICOT Library routine IB01ND. +C The strict lower triangle need not be set to zero. +C On exit, the leading M*NOBR-by-M*NOBR upper triangular +C part of this array is unchanged, and the strict lower +C triangle is set to zero. +C +C LDUF INTEGER +C The leading dimension of the array UF. +C LDUF >= MAX( 1, M*NOBR ). +C +C UN (input) DOUBLE PRECISION array, dimension ( LDUN,N ) +C The leading L*(NOBR-1)-by-N part of this array must +C contain the matrix GaL, i.e., the leading part of the +C first N columns of the matrix Un of relevant singular +C vectors. +C +C LDUN INTEGER +C The leading dimension of the array UN. +C LDUN >= L*(NOBR-1). +C +C UL (input/output) DOUBLE PRECISION array, dimension +C ( LDUL,L*NOBR ) +C On entry, the leading (N+L)-by-L*NOBR part of this array +C must contain the given matrix L. +C On exit, if M > 0, the leading (N+L)-by-L*NOBR part of +C this array is overwritten by the matrix +C [ Q_11 Q_12 ... Q_1,s-2 Q_1,s-1 Q_1s ]. +C +C LDUL INTEGER +C The leading dimension of the array UL. LDUL >= N+L. +C +C PGAL (input) DOUBLE PRECISION array, dimension +C ( LDPGAL,L*(NOBR-1) ) +C The leading N-by-L*(NOBR-1) part of this array must +C contain the pseudoinverse of the matrix GaL, computed by +C SLICOT Library routine IB01PD. +C +C LDPGAL INTEGER +C The leading dimension of the array PGAL. LDPGAL >= N. +C +C K (input) DOUBLE PRECISION array, dimension ( LDK,M*NOBR ) +C The leading (N+L)-by-M*NOBR part of this array must +C contain the given matrix K. +C +C LDK INTEGER +C The leading dimension of the array K. LDK >= N+L. +C +C R (output) DOUBLE PRECISION array, dimension ( LDR,M*(N+L) ) +C The leading (N+L)*M*NOBR-by-M*(N+L) part of this array +C contains details of the complete orthogonal factorization +C of the coefficient matrix T of the least squares problem +C which is solved for getting the system matrices B and D. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX( 1, (N+L)*M*NOBR ). +C +C X (output) DOUBLE PRECISION array, dimension +C ( (N+L)*M*NOBR ) +C The leading M*(N+L) elements of this array contain the +C least squares solution of the system T*X = Kv. +C The remaining elements are used as workspace (to store the +C corresponding part of the vector Kv = vec(K)). +C +C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) +C The leading N-by-M part of this array contains the system +C input matrix. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= N. +C +C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) +C If JOB = 'D', the leading L-by-M part of this array +C contains the system input-output matrix. +C If JOB = 'B', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if JOB = 'D'; +C LDD >= 1, if JOB = 'B'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension ( M*(N+L) ) +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and, if M > 0, DWORK(2) contains the +C reciprocal condition number of the triangular factor of +C the matrix T. +C On exit, if INFO = -26, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( (N+L)*(N+L), 4*M*(N+L)+1 ). +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix T is computed, evaluating the sum of Kronecker +C products, and then the linear system T*X = Kv is solved in a +C least squares sense. The matrices B and D are then directly +C obtained from the least squares solution. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Van Overschee, P., and De Moor, B. +C N4SID: Two Subspace Algorithms for the Identification +C of Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [3] Van Overschee, P. +C Subspace Identification : Theory - Implementation - +C Applications. +C Ph. D. Thesis, Department of Electrical Engineering, +C Katholieke Universiteit Leuven, Belgium, Feb. 1995. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Universiteit Leuven, Feb. 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Universiteit Leuven, Sep. 2001. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDB, LDD, LDK, LDPGAL, LDR, + $ LDUF, LDUL, LDUN, LDWORK, M, N, NOBR + CHARACTER JOB +C .. Array Arguments .. + DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), K(LDK, *), + $ PGAL(LDPGAL, *), R(LDR, *), UF(LDUF, *), + $ UL(LDUL, *), UN(LDUN, *), X(*) + INTEGER IWORK( * ) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, TOLL + INTEGER I, IERR, J, JWORK, LDUN2, LNOBR, LP1, MAXWRK, + $ MINWRK, MKRON, MNOBR, NKRON, NP1, NPL, RANK + LOGICAL WITHB, WITHD +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DGELSY, DGEMM, DLACPY, DLASET, DTRCON, MB01VD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + MNOBR = M*NOBR + LNOBR = L*NOBR + LDUN2 = LNOBR - L + LP1 = L + 1 + NP1 = N + 1 + NPL = N + L + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.WITHB ) THEN + INFO = -1 + ELSE IF( NOBR.LE.1 ) THEN + INFO = -2 + ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LE.0 ) THEN + INFO = -5 + ELSE IF( LDUF.LT.MAX( 1, MNOBR ) ) THEN + INFO = -7 + ELSE IF( LDUN.LT.LDUN2 ) THEN + INFO = -9 + ELSE IF( LDUL.LT.NPL ) THEN + INFO = -11 + ELSE IF( LDPGAL.LT.N ) THEN + INFO = -13 + ELSE IF( LDK.LT.NPL ) THEN + INFO = -15 + ELSE IF( LDR.LT.MAX( 1, MNOBR*NPL ) ) THEN + INFO = -17 + ELSE IF( LDB.LT.N ) THEN + INFO = -20 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MINWRK = MAX( NPL*NPL, 4*M*NPL + 1 ) +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -26 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01PX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Construct the matrix [ Q_11 Q_12 ... Q_1,s-1 Q_1s ] in UL. +C + DO 20 J = 1, L +C + DO 10 I = 1, NPL + UL(I,J) = -UL(I,J) + 10 CONTINUE +C + UL(N+J,J) = ONE + UL(N+J,J) + 20 CONTINUE +C + DO 50 J = LP1, LNOBR +C + DO 30 I = 1, N + UL(I,J) = PGAL(I,J-L) - UL(I,J) + 30 CONTINUE +C + DO 40 I = NP1, NPL + UL(I,J) = -UL(I,J) + 40 CONTINUE +C + 50 CONTINUE +C +C Compute the coefficient matrix T using Kronecker products. +C Workspace: (N+L)*(N+L). +C In the same loop, vectorize K in X. +C + CALL DLASET( 'Full', MNOBR*NPL, M*NPL, ZERO, ZERO, R, LDR ) + CALL DLASET( 'Lower', MNOBR-1, MNOBR-1, ZERO, ZERO, UF(2,1), + $ LDUF ) + JWORK = NPL*L + 1 +C + DO 60 I = 1, NOBR + CALL DLACPY( 'Full', NPL, L, UL(1,(I-1)*L+1), LDUL, DWORK, + $ NPL ) + IF ( I.LT.NOBR ) THEN + CALL DGEMM ( 'NoTranspose', 'NoTranspose', NPL, N, + $ L*(NOBR-I), ONE, UL(1,I*L+1), LDUL, UN, LDUN, + $ ZERO, DWORK(JWORK), NPL ) + ELSE + CALL DLASET( 'Full', NPL, N, ZERO, ZERO, DWORK(JWORK), NPL ) + END IF + CALL MB01VD( 'NoTranspose', 'NoTranspose', MNOBR, M, NPL, + $ NPL, ONE, ONE, UF(1,(I-1)*M+1), LDUF, DWORK, + $ NPL, R, LDR, MKRON, NKRON, IERR ) + CALL DLACPY( 'Full', NPL, M, K(1,(I-1)*M+1), LDK, + $ X((I-1)*NKRON+1), NPL ) + 60 CONTINUE +C +C Compute the tolerance. +C + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = MKRON*NKRON*DLAMCH( 'Precision' ) +C +C Solve the least square problem T*X = vec(K). +C Workspace: need 4*M*(N+L)+1; +C prefer 3*M*(N+L)+(M*(N+L)+1)*NB. +C + DO 70 I = 1, NKRON + IWORK(I) = 0 + 70 CONTINUE +C + CALL DGELSY( MKRON, NKRON, 1, R, LDR, X, MKRON, IWORK, TOLL, RANK, + $ DWORK, LDWORK, IERR ) + MAXWRK = DWORK(1) +C +C Compute the reciprocal of the condition number of the triangular +C factor R of T. +C Workspace: need 3*M*(N+L). +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', NKRON, R, LDR, RCOND, + $ DWORK, IWORK, IERR ) +C + IF ( RANK.LT.NKRON ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 4 + END IF +C +C Construct the matrix D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', L, M, X, NPL, D, LDD ) +C +C Construct the matrix B. +C + CALL DLACPY( 'Full', N, M, X(LP1), NPL, B, LDB ) +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C number in DWORK(2). +C + DWORK(1) = MAX( MINWRK, MAXWRK ) + DWORK(2) = RCOND +C + RETURN +C +C *** Last line of IB01PX *** + END diff --git a/mex/sources/libslicot/IB01PY.f b/mex/sources/libslicot/IB01PY.f new file mode 100644 index 000000000..4b4ff2f5e --- /dev/null +++ b/mex/sources/libslicot/IB01PY.f @@ -0,0 +1,768 @@ + SUBROUTINE IB01PY( METH, JOB, NOBR, N, M, L, RANKR1, UL, LDUL, + $ R1, LDR1, TAU1, PGAL, LDPGAL, K, LDK, R, LDR, + $ H, LDH, B, LDB, D, LDD, TOL, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C 1. To compute the triangular (QR) factor of the p-by-L*s +C structured matrix Q, +C +C [ Q_1s Q_1,s-1 Q_1,s-2 ... Q_12 Q_11 ] +C [ 0 Q_1s Q_1,s-1 ... Q_13 Q_12 ] +C Q = [ 0 0 Q_1s ... Q_14 Q_13 ], +C [ : : : : : ] +C [ 0 0 0 ... 0 Q_1s ] +C +C and apply the transformations to the p-by-m matrix Kexpand, +C +C [ K_1 ] +C [ K_2 ] +C Kexpand = [ K_3 ], +C [ : ] +C [ K_s ] +C +C where, for MOESP approach (METH = 'M'), p = s*(L*s-n), and +C Q_1i = u2(L*(i-1)+1:L*i,:)' is (Ls-n)-by-L, for i = 1:s, +C u2 = Un(1:L*s,n+1:L*s), K_i = K(:,(i-1)*m+1:i*m) (i = 1:s) +C is (Ls-n)-by-m, and for N4SID approach (METH = 'N'), p = s*(n+L), +C and +C +C [ -L_1|1 ] [ M_i-1 - L_1|i ] +C Q_11 = [ ], Q_1i = [ ], i = 2:s, +C [ I_L - L_2|1 ] [ -L_2|i ] +C +C are (n+L)-by-L matrices, and +C K_i = K(:,(i-1)*m+1:i*m), i = 1:s, is (n+L)-by-m. +C The given matrices are: +C For METH = 'M', u2 = Un(1:L*s,n+1:L*s), +C K(1:Ls-n,1:m*s); +C +C [ L_1|1 ... L_1|s ] +C For METH = 'N', L = [ ], (n+L)-by-L*s, +C [ L_2|1 ... L_2|s ] +C +C M = [ M_1 ... M_s-1 ], n-by-L*(s-1), and +C K, (n+L)-by-m*s. +C Matrix M is the pseudoinverse of the matrix GaL, +C built from the first n relevant singular +C vectors, GaL = Un(1:L(s-1),1:n), and computed +C by SLICOT Library routine IB01PD for METH = 'N'. +C +C Matrix Q is triangularized (in R), exploiting its structure, +C and the transformations are applied from the left to Kexpand. +C +C 2. To estimate the matrices B and D of a linear time-invariant +C (LTI) state space model, using the factor R, transformed matrix +C Kexpand, and the singular value decomposition information provided +C by other routines. +C +C IB01PY routine is intended for speed and efficient use of the +C memory space. It is generally not recommended for METH = 'N', as +C IB01PX routine can produce more accurate results. +C +C ARGUMENTS +C +C Mode Parameters +C +C METH CHARACTER*1 +C Specifies the subspace identification method to be used, +C as follows: +C = 'M': MOESP algorithm with past inputs and outputs; +C = 'N': N4SID algorithm. +C +C JOB CHARACTER*1 +C Specifies whether or not the matrices B and D should be +C computed, as follows: +C = 'B': compute the matrix B, but not the matrix D; +C = 'D': compute both matrices B and D; +C = 'N': do not compute the matrices B and D, but only the +C R factor of Q and the transformed Kexpand. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C The number of block rows, s, in the input and output +C Hankel matrices processed by other routines. NOBR > 1. +C +C N (input) INTEGER +C The order of the system. NOBR > N > 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C RANKR1 (input) INTEGER +C The effective rank of the upper triangular matrix r1, +C i.e., the triangular QR factor of the matrix GaL, +C computed by SLICOT Library routine IB01PD. It is also +C the effective rank of the matrix GaL. 0 <= RANKR1 <= N. +C If JOB = 'N', or M = 0, or METH = 'N', this +C parameter is not used. +C +C UL (input/workspace) DOUBLE PRECISION array, dimension +C ( LDUL,L*NOBR ) +C On entry, if METH = 'M', the leading L*NOBR-by-L*NOBR +C part of this array must contain the matrix Un of +C relevant singular vectors. The first N columns of UN +C need not be specified for this routine. +C On entry, if METH = 'N', the leading (N+L)-by-L*NOBR +C part of this array must contain the given matrix L. +C On exit, the leading LDF-by-L*(NOBR-1) part of this array +C is overwritten by the matrix F of the algorithm in [4], +C where LDF = MAX( 1, L*NOBR-N-L ), if METH = 'M'; +C LDF = N, if METH = 'N'. +C +C LDUL INTEGER +C The leading dimension of the array UL. +C LDUL >= L*NOBR, if METH = 'M'; +C LDUL >= N+L, if METH = 'N'. +C +C R1 (input) DOUBLE PRECISION array, dimension ( LDR1,N ) +C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, +C the leading L*(NOBR-1)-by-N part of this array must +C contain details of the QR factorization of the matrix +C GaL, as computed by SLICOT Library routine IB01PD. +C Specifically, the leading N-by-N upper triangular part +C must contain the upper triangular factor r1 of GaL, +C and the lower L*(NOBR-1)-by-N trapezoidal part, together +C with array TAU1, must contain the factored form of the +C orthogonal matrix Q1 in the QR factorization of GaL. +C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' +C and RANKR1 < N, this array is not referenced. +C +C LDR1 INTEGER +C The leading dimension of the array R1. +C LDR1 >= L*(NOBR-1), if JOB <> 'N', M > 0, METH = 'M', +C and RANKR1 = N; +C LDR1 >= 1, otherwise. +C +C TAU1 (input) DOUBLE PRECISION array, dimension ( N ) +C If JOB <> 'N', M > 0, METH = 'M', and RANKR1 = N, +C this array must contain the scalar factors of the +C elementary reflectors used in the QR factorization of the +C matrix GaL, computed by SLICOT Library routine IB01PD. +C If JOB = 'N', or M = 0, or METH = 'N', or METH = 'M' +C and RANKR1 < N, this array is not referenced. +C +C PGAL (input) DOUBLE PRECISION array, dimension +C ( LDPGAL,L*(NOBR-1) ) +C If METH = 'N', or JOB <> 'N', M > 0, METH = 'M' and +C RANKR1 < N, the leading N-by-L*(NOBR-1) part of this +C array must contain the pseudoinverse of the matrix GaL, +C as computed by SLICOT Library routine IB01PD. +C If METH = 'M' and JOB = 'N', or M = 0, or +C RANKR1 = N, this array is not referenced. +C +C LDPGAL INTEGER +C The leading dimension of the array PGAL. +C LDPGAL >= N, if METH = 'N', or JOB <> 'N', M > 0, +C and METH = 'M' and RANKR1 < N; +C LDPGAL >= 1, otherwise. +C +C K (input/output) DOUBLE PRECISION array, dimension +C ( LDK,M*NOBR ) +C On entry, the leading (p/s)-by-M*NOBR part of this array +C must contain the given matrix K defined above. +C On exit, the leading (p/s)-by-M*NOBR part of this array +C contains the transformed matrix K. +C +C LDK INTEGER +C The leading dimension of the array K. LDK >= p/s. +C +C R (output) DOUBLE PRECISION array, dimension ( LDR,L*NOBR ) +C If JOB = 'N', or M = 0, or Q has full rank, the +C leading L*NOBR-by-L*NOBR upper triangular part of this +C array contains the R factor of the QR factorization of +C the matrix Q. +C If JOB <> 'N', M > 0, and Q has not a full rank, the +C leading L*NOBR-by-L*NOBR upper trapezoidal part of this +C array contains details of the complete orhogonal +C factorization of the matrix Q, as constructed by SLICOT +C Library routines MB03OD and MB02QY. +C +C LDR INTEGER +C The leading dimension of the array R. LDR >= L*NOBR. +C +C H (output) DOUBLE PRECISION array, dimension ( LDH,M ) +C If JOB = 'N' or M = 0, the leading L*NOBR-by-M part +C of this array contains the updated part of the matrix +C Kexpand corresponding to the upper triangular factor R +C in the QR factorization of the matrix Q. +C If JOB <> 'N', M > 0, and METH = 'N' or METH = 'M' +C and RANKR1 < N, the leading L*NOBR-by-M part of this +C array contains the minimum norm least squares solution of +C the linear system Q*X = Kexpand, from which the matrices +C B and D are found. The first NOBR-1 row blocks of X +C appear in the reverse order in H. +C If JOB <> 'N', M > 0, METH = 'M' and RANKR1 = N, the +C leading L*(NOBR-1)-by-M part of this array contains the +C matrix product Q1'*X, and the subarray +C L*(NOBR-1)+1:L*NOBR-by-M contains the corresponding +C submatrix of X, with X defined in the phrase above. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= L*NOBR. +C +C B (output) DOUBLE PRECISION array, dimension ( LDB,M ) +C If M > 0, JOB = 'B' or 'D' and INFO = 0, the leading +C N-by-M part of this array contains the system input +C matrix. +C If M = 0 or JOB = 'N', this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if M > 0 and JOB = 'B' or 'D'; +C LDB >= 1, if M = 0 or JOB = 'N'. +C +C D (output) DOUBLE PRECISION array, dimension ( LDD,M ) +C If M > 0, JOB = 'D' and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix. +C If M = 0 or JOB = 'B' or 'N', this array is not +C referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'D'; +C LDD >= 1, if M = 0 or JOB = 'B' or 'N'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; an m-by-n matrix whose estimated +C condition number is less than 1/TOL is considered to +C be of full rank. If the user sets TOL <= 0, then an +C implicitly computed, default tolerance, defined by +C TOLDEF = m*n*EPS, is used instead, where EPS is the +C relative machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not used if M = 0 or JOB = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension ( LIWORK ) +C where LIWORK >= 0, if JOB = 'N', or M = 0; +C LIWORK >= L*NOBR, if JOB <> 'N', and M > 0. +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and, if JOB <> 'N', and M > 0, DWORK(2) +C contains the reciprocal condition number of the triangular +C factor of the matrix R. +C On exit, if INFO = -28, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 2*L, L*NOBR, L+M*NOBR ), +C if JOB = 'N', or M = 0; +C LDWORK >= MAX( L+M*NOBR, L*NOBR + MAX( 3*L*NOBR+1, M ) ), +C if JOB <> 'N', and M > 0. +C For good performance, LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 3: a singular upper triangular matrix was found. +C +C METHOD +C +C The QR factorization is computed exploiting the structure, +C as described in [4]. +C The matrices B and D are then obtained by solving certain +C linear systems in a least squares sense. +C +C REFERENCES +C +C [1] Verhaegen M., and Dewilde, P. +C Subspace Model Identification. Part 1: The output-error +C state-space model identification class of algorithms. +C Int. J. Control, 56, pp. 1187-1210, 1992. +C +C [2] Van Overschee, P., and De Moor, B. +C N4SID: Two Subspace Algorithms for the Identification +C of Combined Deterministic-Stochastic Systems. +C Automatica, Vol.30, No.1, pp. 75-93, 1994. +C +C [3] Van Overschee, P. +C Subspace Identification : Theory - Implementation - +C Applications. +C Ph. D. Thesis, Department of Electrical Engineering, +C Katholieke Universiteit Leuven, Belgium, Feb. 1995. +C +C [4] Sima, V. +C Subspace-based Algorithms for Multivariable System +C Identification. +C Studies in Informatics and Control, 5, pp. 335-344, 1996. +C +C NUMERICAL ASPECTS +C +C The implemented method for computing the triangular factor and +C updating Kexpand is numerically stable. +C +C FURTHER COMMENTS +C +C The computed matrices B and D are not the least squares solutions +C delivered by either MOESP or N4SID algorithms, except for the +C special case n = s - 1, L = 1. However, the computed B and D are +C frequently good enough estimates, especially for METH = 'M'. +C Better estimates could be obtained by calling SLICOT Library +C routine IB01PX, but it is less efficient, and requires much more +C workspace. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 1999. +C +C REVISIONS +C +C Feb. 2000, Sep. 2001, March 2005. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDB, LDD, LDH, LDK, LDPGAL, + $ LDR, LDR1, LDUL, LDWORK, M, N, NOBR, RANKR1 + CHARACTER JOB, METH +C .. Array Arguments .. + DOUBLE PRECISION B(LDB, *), D(LDD, *), DWORK(*), H(LDH, *), + $ K(LDK, *), PGAL(LDPGAL, *), R(LDR, *), + $ R1(LDR1, *), TAU1(*), UL(LDUL, *) + INTEGER IWORK( * ) +C .. Local Scalars .. + DOUBLE PRECISION EPS, RCOND, SVLMAX, THRESH, TOLL + INTEGER I, IERR, ITAU, J, JI, JL, JM, JWORK, LDUN2, + $ LNOBR, LP1, MAXWRK, MINWRK, MNOBR, NOBRH, + $ NROW, NROWML, RANK + LOGICAL MOESP, N4SID, WITHB, WITHD +C .. Local Array .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP, + $ DTRCON, DTRSM, DTRTRS, MA02AD, MB02QY, MB03OD, + $ MB04OD, MB04OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MOD +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MOESP = LSAME( METH, 'M' ) + N4SID = LSAME( METH, 'N' ) + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + MNOBR = M*NOBR + LNOBR = L*NOBR + LDUN2 = LNOBR - L + LP1 = L + 1 + IF ( MOESP ) THEN + NROW = LNOBR - N + ELSE + NROW = N + L + END IF + NROWML = NROW - L + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( MOESP .OR. N4SID ) ) THEN + INFO = -1 + ELSE IF( .NOT.( WITHB .OR. LSAME( JOB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( NOBR.LE.1 ) THEN + INFO = -3 + ELSE IF( N.GE.NOBR .OR. N.LE.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( L.LE.0 ) THEN + INFO = -6 + ELSE IF( ( MOESP .AND. WITHB .AND. M.GT.0 ) .AND. + $ ( RANKR1.LT.ZERO .OR. RANKR1.GT.N ) ) THEN + INFO = -7 + ELSE IF( ( MOESP .AND. LDUL.LT.LNOBR ) .OR. + $ ( N4SID .AND. LDUL.LT.NROW ) ) THEN + INFO = -9 + ELSE IF( LDR1.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. MOESP .AND. + $ LDR1.LT.LDUN2 .AND. RANKR1.EQ.N ) ) THEN + INFO = -11 + ELSE IF( LDPGAL.LT.1 .OR. + $ ( LDPGAL.LT.N .AND. ( N4SID .OR. ( WITHB .AND. M.GT.0 + $ .AND. ( MOESP .AND. RANKR1.LT.N ) ) ) ) ) + $ THEN + INFO = -14 + ELSE IF( LDK.LT.NROW ) THEN + INFO = -16 + ELSE IF( LDR.LT.LNOBR ) THEN + INFO = -18 + ELSE IF( LDH.LT.LNOBR ) THEN + INFO = -20 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. WITHB .AND. LDB.LT.N ) ) + $ THEN + INFO = -22 + ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. WITHD .AND. LDD.LT.L ) ) + $ THEN + INFO = -24 + ELSE +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MINWRK = MAX( 2*L, LNOBR, L + MNOBR ) + MAXWRK = MINWRK + MAXWRK = MAX( MAXWRK, L + L*ILAENV( 1, 'DGEQRF', ' ', NROW, L, + $ -1, -1 ) ) + MAXWRK = MAX( MAXWRK, L + LDUN2*ILAENV( 1, 'DORMQR', 'LT', + $ NROW, LDUN2, L, -1 ) ) + MAXWRK = MAX( MAXWRK, L + MNOBR*ILAENV( 1, 'DORMQR', 'LT', + $ NROW, MNOBR, L, -1 ) ) +C + IF( M.GT.0 .AND. WITHB ) THEN + MINWRK = MAX( MINWRK, 4*LNOBR+1, LNOBR + M ) + MAXWRK = MAX( MINWRK, MAXWRK, LNOBR + + $ M*ILAENV( 1, 'DORMQR', 'LT', LNOBR, M, LNOBR, + $ -1 ) ) + END IF +C + IF ( LDWORK.LT.MINWRK ) THEN + INFO = -28 + DWORK( 1 ) = MINWRK + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01PY', -INFO ) + RETURN + END IF +C +C Construct in R the first block-row of Q, i.e., the +C (p/s)-by-L*s matrix [ Q_1s ... Q_12 Q_11 ], where +C Q_1i, defined above, is (p/s)-by-L, for i = 1:s. +C + IF ( MOESP ) THEN +C + DO 10 I = 1, NOBR + CALL MA02AD( 'Full', L, NROW, UL(L*(I-1)+1,N+1), LDUL, + $ R(1,L*(NOBR-I)+1), LDR ) + 10 CONTINUE +C + ELSE + JL = LNOBR + JM = LDUN2 +C + DO 50 JI = 1, LDUN2, L +C + DO 40 J = JI + L - 1, JI, -1 +C + DO 20 I = 1, N + R(I,J) = PGAL(I,JM) - UL(I,JL) + 20 CONTINUE +C + DO 30 I = N + 1, NROW + R(I,J) = -UL(I,JL) + 30 CONTINUE +C + JL = JL - 1 + JM = JM - 1 + 40 CONTINUE +C + 50 CONTINUE +C + DO 70 J = LNOBR, LDUN2 + 1, -1 +C + DO 60 I = 1, NROW + R(I,J) = -UL(I,JL) + 60 CONTINUE +C + JL = JL - 1 + R(N+J-LDUN2,J) = ONE + R(N+J-LDUN2,J) + 70 CONTINUE + END IF +C +C Triangularize the submatrix Q_1s using an orthogonal matrix S. +C Workspace: need 2*L, prefer L+L*NB. +C + ITAU = 1 + JWORK = ITAU + L +C + CALL DGEQRF( NROW, L, R, LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Apply the transformation S' to the matrix +C [ Q_1,s-1 ... Q_11 ]. Therefore, +C +C [ R P_s-1 P_s-2 ... P_2 P_1 ] +C S'[ Q_1,s ... Q_11 ] = [ ]. +C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] +C +C Workspace: need L*NOBR, prefer L+(L*NOBR-L)*NB. +C + CALL DORMQR( 'Left', 'Transpose', NROW, LDUN2, L, R, LDR, + $ DWORK(ITAU), R(1,LP1), LDR, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Apply the transformation S' to each of the submatrices K_i of +C Kexpand = [ K_1' K_2' ... K_s' ]', K_i = K(:,(i-1)*m+1:i*m) +C (i = 1:s) being (p/s)-by-m. Denote ( H_i' G_i' )' = S'K_i +C (i = 1:s), where H_i has L rows. +C Finally, H_i is saved in H(L*(i-1)+1:L*i,1:m), i = 1:s. +C (G_i is in K(L+1:p/s,(i-1)*m+1:i*m), i = 1:s.) +C Workspace: need L+M*NOBR, prefer L+M*NOBR*NB. +C + CALL DORMQR( 'Left', 'Transpose', NROW, MNOBR, L, R, LDR, + $ DWORK(ITAU), K, LDK, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) +C +C Put the rows to be annihilated (matrix F) in UL(1:p/s-L,1:L*s-L). +C + CALL DLACPY( 'Full', NROWML, LDUN2, R(LP1,LP1), LDR, UL, LDUL ) +C +C Now, the structure of the transformed matrices is: +C +C [ R P_s-1 P_s-2 ... P_2 P_1 ] [ H_1 ] +C [ 0 R P_s-1 ... P_3 P_2 ] [ H_2 ] +C [ 0 0 R ... P_4 P_3 ] [ H_3 ] +C [ : : : : : ] [ : ] +C [ 0 0 0 ... R P_s-1 ] [ H_s-1 ] +C Q = [ 0 0 0 ... 0 R ], Kexpand = [ H_s ], +C [ 0 F_s-1 F_s-2 ... F_2 F_1 ] [ G_1 ] +C [ 0 0 F_s-1 ... F_3 F_2 ] [ G_2 ] +C [ : : : : : ] [ : ] +C [ 0 0 0 ... 0 F_s-1 ] [ G_s-1 ] +C [ 0 0 0 ... 0 0 ] [ G_s ] +C +C where the block-rows have been permuted, to better exploit the +C structure. The block-rows having R on the diagonal are dealt +C with successively in the array R. +C The F submatrices are stored in the array UL, as a block-row. +C +C Copy H_1 in H(1:L,1:m). +C + CALL DLACPY( 'Full', L, M, K, LDK, H, LDH ) +C +C Triangularize the transformed matrix exploiting its structure. +C Workspace: need L+MAX(L-1,L*NOBR-2*L,M*(NOBR-1)). +C + DO 90 I = 1, NOBR - 1 +C +C Copy part of the preceding block-row and then annihilate the +C current submatrix F_s-i using an orthogonal matrix modifying +C the corresponding submatrix R. Simultaneously, apply the +C transformation to the corresponding block-rows of the matrices +C R and F. +C + CALL DLACPY( 'Upper', L, LNOBR-L*I, R(L*(I-1)+1,L*(I-1)+1), + $ LDR, R(L*I+1,L*I+1), LDR ) + CALL MB04OD( 'Full', L, LNOBR-L*(I+1), NROWML, R(L*I+1,L*I+1), + $ LDR, UL(1,L*(I-1)+1), LDUL, R(L*I+1,L*(I+1)+1), + $ LDR, UL(1,L*I+1), LDUL, DWORK(ITAU), DWORK(JWORK) + $ ) +C +C Apply the transformation to the corresponding block-rows of +C the matrix G and copy H_(i+1) in H(L*i+1:L*(i+1),1:m). +C + DO 80 J = 1, L + CALL MB04OY( NROWML, M*(NOBR-I), UL(1,L*(I-1)+J), DWORK(J), + $ K(J,M*I+1), LDK, K(LP1,1), LDK, DWORK(JWORK) ) + 80 CONTINUE +C + CALL DLACPY( 'Full', L, M, K(1,M*I+1), LDK, H(L*I+1,1), LDH ) + 90 CONTINUE +C +C Return if only the factorization is needed. +C + IF( M.EQ.0 .OR. .NOT.WITHB ) THEN + DWORK(1) = MAXWRK + RETURN + END IF +C +C Set the precision parameters. A threshold value EPS**(2/3) is +C used for deciding to use pivoting or not, where EPS is the +C relative machine precision (see LAPACK Library routine DLAMCH). +C + EPS = DLAMCH( 'Precision' ) + THRESH = EPS**( TWO/THREE ) + TOLL = TOL + IF( TOLL.LE.ZERO ) + $ TOLL = LNOBR*LNOBR*EPS + SVLMAX = ZERO +C +C Compute the reciprocal of the condition number of the triangular +C factor R of Q. +C Workspace: need 3*L*NOBR. +C + CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LNOBR, R, LDR, RCOND, + $ DWORK, IWORK, IERR ) +C + IF ( RCOND.GT.MAX( TOLL, THRESH ) ) THEN +C +C The triangular factor R is considered to be of full rank. +C Solve for X, R*X = H. +C + CALL DTRSM( 'Left', 'Upper', 'NoTranspose', 'Non-unit', + $ LNOBR, M, ONE, R, LDR, H, LDH ) + ELSE +C +C Rank-deficient triangular factor R. Compute the +C minimum-norm least squares solution of R*X = H using +C the complete orthogonal factorization of R. +C + DO 100 I = 1, LNOBR + IWORK(I) = 0 + 100 CONTINUE +C +C Workspace: need 4*L*NOBR+1; +C prefer 3*L*NOBR+(L*NOBR+1)*NB. +C + JWORK = ITAU + LNOBR + CALL DLASET( 'Lower', LNOBR-1, LNOBR, ZERO, ZERO, R(2,1), LDR ) + CALL MB03OD( 'QR', LNOBR, LNOBR, R, LDR, IWORK, TOLL, SVLMAX, + $ DWORK(ITAU), RANK, SVAL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need L*NOBR+M; prefer L*NOBR+M*NB. +C + CALL DORMQR( 'Left', 'Transpose', LNOBR, M, LNOBR, R, LDR, + $ DWORK(ITAU), H, LDH, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + IF ( RANK.LT.LNOBR ) THEN +C +C The least squares problem is rank-deficient. +C + IWARN = 4 + END IF +C +C Workspace: need L*NOBR+max(L*NOBR,M); prefer larger. +C + CALL MB02QY( LNOBR, LNOBR, M, RANK, R, LDR, IWORK, H, LDH, + $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C +C Construct the matrix D, if needed. +C + IF ( WITHD ) + $ CALL DLACPY( 'Full', L, M, H(LDUN2+1,1), LDH, D, LDD ) +C +C Compute B by solving another linear system (possibly in +C a least squares sense). +C +C Make a block-permutation of the rows of the right-hand side, H, +C to construct the matrix +C +C [ H(L*(s-2)+1:L*(s-1),:); ... H(L+1:L*2,:); H(1:L),:) ] +C +C in H(1:L*s-L,1:n). +C + NOBRH = NOBR/2 + MOD( NOBR, 2 ) - 1 +C + DO 120 J = 1, M +C + DO 110 I = 1, NOBRH + CALL DSWAP( L, H(L*(I-1)+1,J), 1, H(L*(NOBR-I-1)+1,J), 1 ) + 110 CONTINUE +C + 120 CONTINUE +C +C Solve for B the matrix equation GaL*B = H(1:L*s-L,:), using +C the available QR factorization of GaL, if METH = 'M' and +C rank(GaL) = n, or the available pseudoinverse of GaL, otherwise. +C + IF ( MOESP .AND. RANKR1.EQ.N ) THEN +C +C The triangular factor r1 of GaL is considered to be of +C full rank. Compute Q1'*H in H and then solve for B, +C r1*B = H(1:n,:) in B, where Q1 is the orthogonal matrix +C in the QR factorization of GaL. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( 'Left', 'Transpose', LDUN2, M, N, R1, LDR1, + $ TAU1, H, LDH, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C +C Compute the solution in B. +C + CALL DLACPY( 'Full', N, M, H, LDH, B, LDB ) +C + CALL DTRTRS( 'Upper', 'NoTranspose', 'NonUnit', N, M, R1, LDR1, + $ B, LDB, IERR ) + IF ( IERR.GT.0 ) THEN + INFO = 3 + RETURN + END IF + ELSE +C +C Rank-deficient triangular factor r1. Use the available +C pseudoinverse of GaL for computing B from GaL*B = H. +C + CALL DGEMM ( 'NoTranspose', 'NoTranspose', N, M, LDUN2, ONE, + $ PGAL, LDPGAL, H, LDH, ZERO, B, LDB ) + END IF +C +C Return optimal workspace in DWORK(1) and reciprocal condition +C number in DWORK(2). +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND +C + RETURN +C +C *** Last line of IB01PY *** + END diff --git a/mex/sources/libslicot/IB01QD.f b/mex/sources/libslicot/IB01QD.f new file mode 100644 index 000000000..93bf15663 --- /dev/null +++ b/mex/sources/libslicot/IB01QD.f @@ -0,0 +1,1081 @@ + SUBROUTINE IB01QD( JOBX0, JOB, N, M, L, NSMP, A, LDA, C, LDC, U, + $ LDU, Y, LDY, X0, B, LDB, D, LDD, TOL, IWORK, + $ DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the initial state and the system matrices B and D +C of a linear time-invariant (LTI) discrete-time system, given the +C matrix pair (A,C) and the input and output trajectories of the +C system. The model structure is : +C +C x(k+1) = Ax(k) + Bu(k), k >= 0, +C y(k) = Cx(k) + Du(k), +C +C where x(k) is the n-dimensional state vector (at time k), +C u(k) is the m-dimensional input vector, +C y(k) is the l-dimensional output vector, +C and A, B, C, and D are real matrices of appropriate dimensions. +C Matrix A is assumed to be in a real Schur form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX0 CHARACTER*1 +C Specifies whether or not the initial state should be +C computed, as follows: +C = 'X': compute the initial state x(0); +C = 'N': do not compute the initial state (x(0) is known +C to be zero). +C +C JOB CHARACTER*1 +C Specifies which matrices should be computed, as follows: +C = 'B': compute the matrix B only (D is known to be zero); +C = 'D': compute the matrices B and D. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples, t). +C NSMP >= N*M + a + e, where +C a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'; +C e = 0, if JOBX0 = 'X' and JOB = 'B'; +C e = 1, if JOBX0 = 'N' and JOB = 'B'; +C e = M, if JOB = 'D'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array must contain the +C system output matrix C (corresponding to the real Schur +C form of A). +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= L. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,M) +C On entry, the leading NSMP-by-M part of this array must +C contain the t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C On exit, if JOB = 'D', the leading NSMP-by-M part of +C this array contains details of the QR factorization of +C the t-by-m matrix U, possibly computed sequentially +C (see METHOD). +C If JOB = 'B', this array is unchanged on exit. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,NSMP), if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C If JOBX0 = 'X', the estimated initial state of the +C system, x(0). +C If JOBX0 = 'N', x(0) is set to zero without any +C calculations. +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C If N > 0, M > 0, and INFO = 0, the leading N-by-M +C part of this array contains the system input matrix B +C in the coordinates corresponding to the real Schur form +C of A. +C If N = 0 or M = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if N > 0 and M > 0; +C LDB >= 1, if N = 0 or M = 0. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C If M > 0, JOB = 'D', and INFO = 0, the leading +C L-by-M part of this array contains the system input-output +C matrix D. +C If M = 0 or JOB = 'B', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'D'; +C LDD >= 1, if M = 0 or JOB = 'B'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; a matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then EPS is used +C instead, where EPS is the relative machine precision +C (see LAPACK Library routine DLAMCH). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= N*M + a, if JOB = 'B', +C LIWORK >= max( N*M + a, M ), if JOB = 'D', +C with a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; DWORK(2) contains the reciprocal condition +C number of the triangular factor of the QR factorization of +C the matrix W2 (see METHOD); if M > 0 and JOB = 'D', +C DWORK(3) contains the reciprocal condition number of the +C triangular factor of the QR factorization of U. +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( LDW1, min( LDW2, LDW3 ) ), where +C LDW1 = 2, if M = 0 or JOB = 'B', +C LDW1 = 3, if M > 0 and JOB = 'D', +C LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ), +C LDW2 = LDWa, if M = 0 or JOB = 'B', +C LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C LDWb = (b + r)*(r + 1) + +C max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ), +C LDW3 = LDWb, if M = 0 or JOB = 'B', +C LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ), +C if M > 0 and JOB = 'D', +C r = N*M + a, +C a = 0, if JOBX0 = 'N', +C a = N, if JOBX0 = 'X'; +C b = 0, if JOB = 'B', +C b = L*M, if JOB = 'D'; +C c = 0, if JOBX0 = 'N', +C c = L*N, if JOBX0 = 'X'; +C d = 0, if JOBX0 = 'N', +C d = 2*N*N + N, if JOBX0 = 'X'; +C f = 2*r, if JOB = 'B' or M = 0, +C f = M + max( 2*r, M ), if JOB = 'D' and M > 0; +C q = b + r*L. +C For good performance, LDWORK should be larger. +C If LDWORK >= LDW2 or +C LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + +C max( d, f ), +C then standard QR factorizations of the matrices U and/or +C W2 (see METHOD) are used. +C Otherwise, the QR factorizations are computed sequentially +C by performing NCYCLE cycles, each cycle (except possibly +C the last one) processing s < t samples, where s is +C chosen from the equation +C LDWORK = s*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c + +C max( d, f ). +C (s is at least N*M+a+e, the minimum value of NSMP.) +C The computational effort may increase and the accuracy may +C decrease with the decrease of s. Recommended value is +C LDWORK = LDW2, assuming a large enough cache size, to +C also accommodate A, C, U, and Y. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C An extension and refinement of the method in [1,2] is used. +C Specifically, denoting +C +C X = [ vec(D')' vec(B)' x0' ]', +C +C where vec(M) is the vector obtained by stacking the columns of +C the matrix M, then X is the least squares solution of the +C system S*X = vec(Y), with the matrix S = [ diag(U) W ], +C defined by +C +C ( U | | ... | | | ... | | ) +C ( U | 11 | ... | n1 | 12 | ... | nm | ) +C S = ( : | y | ... | y | y | ... | y | P*Gamma ), +C ( : | | ... | | | ... | | ) +C ( U | | ... | | | ... | | ) +C ij +C diag(U) having L block rows and columns. In this formula, y +C are the outputs of the system for zero initial state computed +C using the following model, for j = 1:m, and for i = 1:n, +C ij ij ij +C x (k+1) = Ax (k) + e_i u_j(k), x (0) = 0, +C +C ij ij +C y (k) = Cx (k), +C +C where e_i is the i-th n-dimensional unit vector, Gamma is +C given by +C +C ( C ) +C ( C*A ) +C Gamma = ( C*A^2 ), +C ( : ) +C ( C*A^(t-1) ) +C +C and P is a permutation matrix that groups together the rows of +C Gamma depending on the same row of C, namely +C [ c_j; c_j*A; c_j*A^2; ... c_j*A^(t-1) ], for j = 1:L. +C The first block column, diag(U), is not explicitly constructed, +C but its structure is exploited. The last block column is evaluated +C using powers of A with exponents 2^k. No interchanges are applied. +C A special QR decomposition of the matrix S is computed. Let +C U = q*[ r' 0 ]' be the QR decomposition of U, if M > 0, where +C r is M-by-M. Then, diag(q') is applied to W and vec(Y). +C The block-rows of S and vec(Y) are implicitly permuted so that +C matrix S becomes +C +C ( diag(r) W1 ) +C ( 0 W2 ), +C +C where W1 has L*M rows. Then, the QR decomposition of W2 is +C computed (sequentially, if M > 0) and used to obtain B and x0. +C The intermediate results and the QR decomposition of U are +C needed to find D. If a triangular factor is too ill conditioned, +C then singular value decomposition (SVD) is employed. SVD is not +C generally needed if the input sequence is sufficiently +C persistently exciting and NSMP is large enough. +C If the matrix W cannot be stored in the workspace (i.e., +C LDWORK < LDW2), the QR decompositions of W2 and U are +C computed sequentially. +C +C REFERENCES +C +C [1] Verhaegen M., and Varga, A. +C Some Experience with the MOESP Class of Subspace Model +C Identification Methods in Identifying the BO105 Helicopter. +C Report TR R165-94, DLR Oberpfaffenhofen, 1994. +C +C [2] Sima, V., and Varga, A. +C RASP-IDENT : Subspace Model Identification Programs. +C Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V., +C Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C FURTHER COMMENTS +C +C The algorithm for computing the system matrices B and D is +C less efficient than the MOESP or N4SID algorithms implemented in +C SLICOT Library routine IB01PD, because a large least squares +C problem has to be solved, but the accuracy is better, as the +C computed matrices B and D are fitted to the input and output +C trajectories. However, if matrix A is unstable, the computed +C matrices B and D could be inaccurate. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, + $ LDWORK, LDY, M, N, NSMP + CHARACTER JOB, JOBX0 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, RCONDU, TOLL + INTEGER I, I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, + $ IG, IGAM, IGS, INI, INIH, INIR, INIS, INY, + $ INYGAM, IQ, IREM, IRHS, ISIZE, ISV, ITAU, + $ ITAUU, IUPNT, IX, IXINIT, IXSAVE, IY, IYPNT, J, + $ JWORK, K, LDDW, LDR, LDW2, LDW3, LM, LN, LNOB, + $ MAXWRK, MINSMP, MINWLS, MINWRK, N2M, NCOL, + $ NCP1, NCYCLE, NM, NN, NOBS, NROW, NSMPL, RANK + LOGICAL FIRST, NCYC, POWER2, WITHB, WITHD, WITHX0 +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, + $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSM, + $ MA02AD, MB01TD, MB02UD, MB04OD, MB04OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD +C .. Executable Statements .. +C +C Check the input parameters. +C + WITHD = LSAME( JOB, 'D' ) + WITHB = LSAME( JOB, 'B' ) .OR. WITHD + WITHX0 = LSAME( JOBX0, 'X' ) +C + IWARN = 0 + INFO = 0 + LM = L*M + LN = L*N + NN = N*N + NM = N*M + N2M = N*NM + NCOL = NM + IF( WITHX0 ) + $ NCOL = NCOL + N + MINSMP = NCOL + IF( WITHD ) THEN + MINSMP = MINSMP + M + IQ = MINSMP + ELSE IF ( .NOT.WITHX0 ) THEN + IQ = MINSMP + MINSMP = MINSMP + 1 + ELSE + IQ = MINSMP + END IF +C + IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.WITHB ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LE.0 ) THEN + INFO = -5 + ELSE IF( NSMP.LT.MINSMP ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.L ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -12 + ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) + $ THEN + INFO = -17 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -19 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -20 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + NSMPL = NSMP*L + IQ = IQ*L + NCP1 = NCOL + 1 + ISIZE = NSMPL*NCP1 + IF ( N.GT.0 .AND. WITHX0 ) THEN + IC = 2*NN + N + ELSE + IC = 0 + END IF + MINWLS = NCOL*NCP1 + IF ( WITHD ) + $ MINWLS = MINWLS + LM*NCP1 + IF ( M.GT.0 .AND. WITHD ) THEN + IA = M + MAX( 2*NCOL, M ) + ELSE + IA = 2*NCOL + END IF + ITAU = N2M + MAX( IC, IA ) + IF ( WITHX0 ) + $ ITAU = ITAU + LN + LDW2 = ISIZE + MAX( N + MAX( IC, IA ), 6*NCOL ) + LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL ) + IF ( M.GT.0 .AND. WITHD ) THEN + LDW2 = MAX( LDW2, ISIZE + 2*M*M + 6*M ) + LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M ) + END IF + MINWRK = MIN( LDW2, LDW3 ) + MINWRK = MAX( MINWRK, 2 ) + IF ( M.GT.0 .AND. WITHD ) + $ MINWRK = MAX( MINWRK, 3 ) + IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN + IF ( M.GT.0 .AND. WITHD ) THEN + MAXWRK = ISIZE + N + M + + $ MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP, M, -1, -1 ), + $ NCOL + NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMP-M, + $ NCOL, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, ISIZE + N + M + + $ MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT', NSMP, + $ NCP1, M, -1 ), + $ NCOL + ILAENV( 1, 'DORMQR', 'LT', + $ NSMP-M, 1, NCOL, -1 ) ) ) + ELSE + MAXWRK = ISIZE + N + NCOL + + $ MAX( NCOL*ILAENV( 1, 'DGEQRF', ' ', NSMPL, NCOL, + $ -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT',NSMPL, 1, NCOL, + $ -1 ) ) + END IF + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF +C + IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN + INFO = -23 + DWORK(1) = MINWRK + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M ).EQ.0 ) THEN + DWORK(2) = ONE + IF ( M.GT.0 .AND. WITHD ) THEN + DWORK(1) = THREE + DWORK(3) = ONE + ELSE + DWORK(1) = TWO + END IF + RETURN + END IF +C +C Set up the least squares problem, either directly, if enough +C workspace, or sequentially, otherwise. +C + IYPNT = 1 + IUPNT = 1 + LDDW = ( LDWORK - MINWLS - ITAU )/NCP1 + NOBS = MIN( NSMP, LDDW/L ) +C + IF ( LDWORK.GE.LDW2 .OR. NSMP.LE.NOBS ) THEN +C +C Enough workspace for solving the problem directly. +C + NCYCLE = 1 + NOBS = NSMP + LDDW = MAX( 1, NSMPL ) + IF ( WITHD ) THEN + INIR = M + 1 + ELSE + INIR = 1 + END IF + INY = 1 + INIS = 1 + ELSE +C +C NCYCLE > 1 cycles are needed for solving the problem +C sequentially, taking NOBS samples in each cycle (or the +C remaining samples in the last cycle). +C + LNOB = L*NOBS + LDDW = MAX( 1, LNOB ) + NCYCLE = NSMP/NOBS + IF ( MOD( NSMP, NOBS ).NE.0 ) + $ NCYCLE = NCYCLE + 1 + INIR = 1 + INIH = INIR + NCOL*NCOL + INIS = INIH + NCOL + IF ( WITHD ) THEN + INY = INIS + LM*NCP1 + ELSE + INY = INIS + END IF + END IF +C + NCYC = NCYCLE.GT.1 + INYGAM = INY + LDDW*NM + IRHS = INY + LDDW*NCOL + IXINIT = IRHS + LDDW + IF( NCYC ) THEN + IC = IXINIT + N2M + IF ( WITHX0 ) THEN + IA = IC + LN + ELSE + IA = IC + END IF + LDR = MAX( 1, NCOL ) + IE = INY + ELSE + IF ( WITHD ) THEN + INIH = IRHS + M + ELSE + INIH = IRHS + END IF + IA = IXINIT + N + LDR = LDDW + IE = IXINIT + END IF + IF ( N.GT.0 .AND. WITHX0 ) + $ IAS = IA + NN +C + ITAUU = IA + IF ( WITHD ) THEN + ITAU = ITAUU + M + ELSE + ITAU = ITAUU + END IF + DUM(1) = ZERO +C + DO 190 ICYCLE = 1, NCYCLE + FIRST = ICYCLE.EQ.1 + IF ( .NOT.FIRST ) THEN + IF ( ICYCLE.EQ.NCYCLE ) THEN + NOBS = NSMP - ( NCYCLE - 1 )*NOBS + LNOB = L*NOBS + END IF + END IF +C + IY = INY + IXSAVE = IXINIT +C +C Compute the M*N output trajectories for zero initial state +C or for the saved final state value of the previous cycle. +C This can be performed in parallel. +C Workspace: need s*L*(r + 1) + b + w, +C where r = M*N + a, s = NOBS, +C a = 0, if JOBX0 = 'N'; +C a = N, if JOBX0 = 'X'; +C b = N, if NCYCLE = 1; +C b = N*N*M, if NCYCLE > 1; +C w = 0, if NCYCLE = 1; +C w = r*(r+1), if NCYCLE > 1, JOB = 'B'; +C w = (M*L+r)*(r+1), if NCYCLE > 1, JOB = 'D'. +C + DO 40 J = 1, M + DO 30 I = 1, N +C ij +C Compute the y trajectory and put the vectorized form +C of it in an appropriate column of DWORK. To gain in +C efficiency, a specialization of SLICOT Library routine +C TF01ND is used. +C + IF ( FIRST ) + $ CALL DCOPY( N, DUM, 0, DWORK(IXSAVE), 1 ) + CALL DCOPY( N, DWORK(IXSAVE), 1, X0, 1 ) + INI = IY +C + DO 20 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, ONE, C, LDC, X0, 1, + $ ZERO, DWORK(IY), NOBS ) + IY = IY + 1 + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 10 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXSAVE+IX-2) + 10 CONTINUE +C + X0(I) = X0(I) + U(IUPNT+K-1,J) + CALL DCOPY( N, X0, 1, DWORK(IXSAVE), 1 ) + 20 CONTINUE +C + IF ( NCYC ) + $ IXSAVE = IXSAVE + N + IY = INI + LDDW + 30 CONTINUE +C + 40 CONTINUE +C + IF ( N.GT.0 .AND. WITHX0 ) THEN +C +C Compute the permuted extended observability matrix Gamma +C ij +C in the following N columns of DWORK (after the y +C trajectories). Gamma is directly constructed in the +C required row structure. +C Workspace: need s*L*(r + 1) + 2*N*N + N + b + c + w, +C where c = 0, if NCYCLE = 1; +C c = L*N, if NCYCLE > 1. +C + JWORK = IAS + NN + IG = INYGAM + IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) + IREM = NOBS - 2**IEXPON + POWER2 = IREM.EQ.0 + IF ( .NOT.POWER2 ) + $ IEXPON = IEXPON + 1 +C + IF ( FIRST ) THEN +C + DO 50 I = 1, N + CALL DCOPY( L, C(1,I), 1, DWORK(IG), NOBS ) + IG = IG + LDDW + 50 CONTINUE +C + ELSE +C + DO 60 I = IC, IC + LN - 1, L + CALL DCOPY( L, DWORK(I), 1, DWORK(IG), NOBS ) + IG = IG + LDDW + 60 CONTINUE +C + END IF +C p +C Use powers of the matrix A: A , p = 2**(J-1). +C + CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) + IF( N.GT.1 ) + $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) + I2 = 1 + NROW = 0 +C + DO 90 J = 1, IEXPON + IGAM = INYGAM + IF ( J.LT.IEXPON .OR. POWER2 ) THEN + NROW = I2 + ELSE + NROW = IREM + END IF +C + DO 80 I = 1, L + CALL DLACPY( 'Full', NROW, N, DWORK(IGAM), LDDW, + $ DWORK(IGAM+I2), LDDW ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', + $ 'Non Unit', NROW, N, ONE, DWORK(IA), N, + $ DWORK(IGAM+I2), LDDW ) + IG = IGAM +C p +C Compute the contribution of the subdiagonal of A +C to the product. +C + DO 70 IX = 1, N - 1 + CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), + $ DWORK(IG+LDDW), 1, DWORK(IG+I2), 1 ) + IG = IG + LDDW + 70 CONTINUE +C + IGAM = IGAM + NOBS + 80 CONTINUE +C + IF ( J.LT.IEXPON ) THEN + CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), + $ N ) + IF( N.GT.1 ) + $ CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), + $ N+1 ) + CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, + $ DWORK(JWORK), IERR ) + I2 = I2*2 + END IF + 90 CONTINUE +C + IF ( NCYC .AND. ICYCLE.LT.NCYCLE ) THEN + IG = INYGAM + I2 + NROW - 1 + IGS = IG +C + DO 100 I = IC, IC + LN - 1, L + CALL DCOPY( L, DWORK(IG), NOBS, DWORK(I), 1 ) + IG = IG + LDDW + 100 CONTINUE +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', + $ L, N, ONE, A, LDA, DWORK(IC), L ) + IG = IGS +C +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 110 IX = 1, N - 1 + CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), NOBS, + $ DWORK(IC+(IX-1)*L), 1 ) + IG = IG + LDDW + 110 CONTINUE +C + END IF + END IF +C +C Setup (part of) the right hand side of the least squares +C problem. +C + IY = IRHS +C + DO 120 K = 1, L + CALL DCOPY( NOBS, Y(IYPNT,K), 1, DWORK(IY), 1 ) + IY = IY + NOBS + 120 CONTINUE +C +C Compress the data using a special QR factorization. +C Workspace: need v + y, +C where v = s*L*(r + 1) + b + c + w + x, +C x = M, y = max( 2*r, M ), +C if JOB = 'D' and M > 0, +C x = 0, y = 2*r, if JOB = 'B' or M = 0. +C + IF ( M.GT.0 .AND. WITHD ) THEN +C +C Case 1: D is requested. +C + JWORK = ITAU + IF ( FIRST ) THEN + INI = INY + M +C +C Compress the first or single segment of U, U1 = Q1*R1. +C Workspace: need v + M; +C prefer v + M*NB. +C + CALL DGEQRF( NOBS, M, U, LDU, DWORK(ITAUU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C ij +C Apply diag(Q1') to the matrix [ y Gamma Y ]. +C Workspace: need v + r + 1, +C prefer v + (r + 1)*NB. +C + DO 130 K = 1, L + CALL DORMQR( 'Left', 'Transpose', NOBS, NCP1, M, U, + $ LDU, DWORK(ITAUU), DWORK(INY+(K-1)*NOBS), + $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, + $ IERR ) + 130 CONTINUE +C + IF ( NCOL.GT.0 ) THEN +C +C Compress the first part of the first data segment of +C ij +C [ y Gamma ]. +C Workspace: need v + 2*r, +C prefer v + r + r*NB. +C + JWORK = ITAU + NCOL + CALL DGEQRF( NOBS-M, NCOL, DWORK(INI), LDDW, + $ DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the corresponding right +C hand side part. +C Workspace: need v + r + 1, +C prefer v + r + NB. +C + CALL DORMQR( 'Left', 'Transpose', NOBS-M, 1, NCOL, + $ DWORK(INI), LDDW, DWORK(ITAU), + $ DWORK(IRHS+M), LDDW, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) +C +C Compress the remaining parts of the first data segment +C ij +C of [ y Gamma ]. +C Workspace: need v + r - 1. +C + DO 140 K = 2, L + CALL MB04OD( 'Full', NCOL, 1, NOBS-M, DWORK(INI), + $ LDDW, DWORK(INI+(K-1)*NOBS), LDDW, + $ DWORK(IRHS+M), LDDW, + $ DWORK(IRHS+M+(K-1)*NOBS), LDDW, + $ DWORK(ITAU), DWORK(JWORK) ) + 140 CONTINUE +C + END IF +C + IF ( NCYC ) THEN +C ij +C Save the triangular factor of [ y Gamma ], the +C corresponding right hand side, and the first M rows +C in each NOBS group of rows. +C Workspace: need v. +C + CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INI), LDDW, + $ DWORK(INIR), LDR ) +C + DO 150 K = 1, L + CALL DLACPY( 'Full', M, NCP1, + $ DWORK(INY +(K-1)*NOBS), LDDW, + $ DWORK(INIS+(K-1)*M), LM ) + 150 CONTINUE +C + END IF + ELSE +C +C Compress the current data segment of U, Ui = Qi*Ri, +C i = ICYCLE. +C Workspace: need v + r + 1. +C + CALL MB04OD( 'Full', M, NCP1, NOBS, U, LDU, U(IUPNT,1), + $ LDU, DWORK(INIS), LM, DWORK(INY), LDDW, + $ DWORK(ITAUU), DWORK(JWORK) ) +C +C Apply diag(Qi') to the appropriate part of the matrix +C ij +C [ y Gamma Y ]. +C Workspace: need v + r + 1. +C + DO 170 K = 2, L +C + DO 160 IX = 1, M + CALL MB04OY( NOBS, NCP1, U(IUPNT,IX), + $ DWORK(ITAUU+IX-1), + $ DWORK(INIS+(K-1)*M+IX-1), LM, + $ DWORK(INY+(K-1)*NOBS), LDDW, + $ DWORK(JWORK) ) + 160 CONTINUE +C + 170 CONTINUE +C + IF ( NCOL.GT.0 ) THEN +C + JWORK = ITAU + NCOL +C +C Compress the current (but not the first) data segment +C ij +C of [ y Gamma ]. +C Workspace: need v + r - 1. +C + DO 180 K = 1, L + CALL MB04OD( 'Full', NCOL, 1, NOBS, DWORK(INIR), + $ LDR, DWORK(INY+(K-1)*NOBS), LDDW, + $ DWORK(INIH), LDR, + $ DWORK(IRHS+(K-1)*NOBS), LDDW, + $ DWORK(ITAU), DWORK(JWORK) ) + 180 CONTINUE +C + END IF + END IF +C + ELSE IF ( NCOL.GT.0 ) THEN +C +C Case 2: D is known to be zero. +C + JWORK = ITAU + NCOL + IF ( FIRST ) THEN +C +C Compress the first or single data segment of +C ij +C [ y Gamma ]. +C Workspace: need v + 2*r, +C prefer v + r + r*NB. +C + CALL DGEQRF( LDDW, NCOL, DWORK(INY), LDDW, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the right hand side. +C Workspace: need v + r + 1, +C prefer v + r + NB. +C + CALL DORMQR( 'Left', 'Transpose', LDDW, 1, NCOL, + $ DWORK(INY), LDDW, DWORK(ITAU), DWORK(IRHS), + $ LDDW, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( NCYC ) THEN +C ij +C Save the triangular factor of [ y Gamma ] and the +C corresponding right hand side. +C Workspace: need v. +C + CALL DLACPY( 'Upper', NCOL, NCP1, DWORK(INY), LDDW, + $ DWORK(INIR), LDR ) + END IF + ELSE +C +C Compress the current (but not the first) data segment. +C Workspace: need v + r - 1. +C + CALL MB04OD( 'Full', NCOL, 1, LNOB, DWORK(INIR), LDR, + $ DWORK(INY), LDDW, DWORK(INIH), LDR, + $ DWORK(IRHS), LDDW, DWORK(ITAU), + $ DWORK(JWORK) ) + END IF + END IF +C + IUPNT = IUPNT + NOBS + IYPNT = IYPNT + NOBS + 190 CONTINUE +C +C Estimate the reciprocal condition number of the triangular factor +C of the QR decomposition. +C Workspace: need u + 3*r, where +C u = t*L*(r + 1), if NCYCLE = 1; +C u = w, if NCYCLE > 1. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', NCOL, DWORK(INIR), + $ LDR, RCOND, DWORK(IE), IWORK, IERR ) +C + TOLL = TOL + IF ( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. +C Workspace: need u + 6*r; +C prefer larger. +C + IF ( NCOL.GT.1 ) + $ CALL DLASET( 'Lower', NCOL-1, NCOL-1, ZERO, ZERO, + $ DWORK(INIR+1), LDR ) + ISV = IE + JWORK = ISV + NCOL + CALL DGELSS( NCOL, NCOL, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, + $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE +C +C Find the least squares solution using QR decomposition only. +C + CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', NCOL, + $ 1, ONE, DWORK(INIR), LDR, DWORK(INIH), LDR ) + END IF +C +C Setup the estimated n-by-m input matrix B, and the estimated +C initial state of the system x0. +C + CALL DLACPY( 'Full', N, M, DWORK(INIH), N, B, LDB ) +C + IF ( N.GT.0 .AND. WITHX0 ) THEN + CALL DCOPY( N, DWORK(INIH+NM), 1, X0, 1 ) + ELSE + CALL DCOPY( N, DUM, 0, X0, 1 ) + END IF +C + IF ( M.GT.0 .AND. WITHD ) THEN +C +C Compute the estimated l-by-m input/output matrix D. +C + IF ( NCYC ) THEN + IRHS = INIS + LM*NCOL + CALL DGEMV( 'No Transpose', LM, NCOL, -ONE, DWORK(INIS), + $ LM, DWORK(INIH), 1, ONE, DWORK(IRHS), 1 ) + ELSE +C + DO 200 K = 1, L + CALL DGEMV( 'No Transpose', M, NCOL, -ONE, + $ DWORK(INIS+(K-1)*NOBS), LDDW, DWORK(INIH), 1, + $ ONE, DWORK(IRHS+(K-1)*NOBS), 1 ) + 200 CONTINUE +C + DO 210 K = 2, L + CALL DCOPY( M, DWORK(IRHS+(K-1)*NOBS), 1, + $ DWORK(IRHS+(K-1)*M), 1 ) + 210 CONTINUE +C + END IF +C +C Estimate the reciprocal condition number of the triangular +C factor of the QR decomposition of the matrix U. +C Workspace: need u + 3*M. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', M, U, LDU, + $ RCONDU, DWORK(IE), IWORK, IERR ) + IF ( RCONDU.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. (QR decomposition of U is preserved.) +C Workspace: need u + 2*M*M + 6*M; +C prefer larger. +C + IQ = IE + M*M + ISV = IQ + M*M + JWORK = ISV + M + CALL DLACPY( 'Upper', M, M, U, LDU, DWORK(IE), M ) + CALL MB02UD( 'Not Factored', 'Left', 'No Transpose', + $ 'No Pinv', M, L, ONE, TOLL, RANK, DWORK(IE), + $ M, DWORK(IQ), M, DWORK(ISV), DWORK(IRHS), M, + $ DUM, 1, DWORK(JWORK), LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE + CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non Unit', M, + $ L, ONE, U, LDU, DWORK(IRHS), M ) + END IF + CALL MA02AD( 'Full', M, L, DWORK(IRHS), M, D, LDD ) +C + END IF +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND + IF ( M.GT.0 .AND. WITHD ) + $ DWORK(3) = RCONDU +C + RETURN +C +C *** End of IB01QD *** + END diff --git a/mex/sources/libslicot/IB01RD.f b/mex/sources/libslicot/IB01RD.f new file mode 100644 index 000000000..b5eaf6125 --- /dev/null +++ b/mex/sources/libslicot/IB01RD.f @@ -0,0 +1,762 @@ + SUBROUTINE IB01RD( JOB, N, M, L, NSMP, A, LDA, B, LDB, C, LDC, D, + $ LDD, U, LDU, Y, LDY, X0, TOL, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the initial state of a linear time-invariant (LTI) +C discrete-time system, given the system matrices (A,B,C,D) and +C the input and output trajectories of the system. The model +C structure is : +C +C x(k+1) = Ax(k) + Bu(k), k >= 0, +C y(k) = Cx(k) + Du(k), +C +C where x(k) is the n-dimensional state vector (at time k), +C u(k) is the m-dimensional input vector, +C y(k) is the l-dimensional output vector, +C and A, B, C, and D are real matrices of appropriate dimensions. +C Matrix A is assumed to be in a real Schur form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies whether or not the matrix D is zero, as follows: +C = 'Z': the matrix D is zero; +C = 'N': the matrix D is not zero. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L > 0. +C +C NSMP (input) INTEGER +C The number of rows of matrices U and Y (number of +C samples used, t). NSMP >= N. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A in a real Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B (corresponding to the real Schur +C form of A). +C If N = 0 or M = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= N, if N > 0 and M > 0; +C LDB >= 1, if N = 0 or M = 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array must contain the +C system output matrix C (corresponding to the real Schur +C form of A). +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= L. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading L-by-M part of this array must contain the +C system input-output matrix. +C If M = 0 or JOB = 'Z', this array is not referenced. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= L, if M > 0 and JOB = 'N'; +C LDD >= 1, if M = 0 or JOB = 'Z'. +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C If M > 0, the leading NSMP-by-M part of this array must +C contain the t-by-m input-data sequence matrix U, +C U = [u_1 u_2 ... u_m]. Column j of U contains the +C NSMP values of the j-th input component for consecutive +C time increments. +C If M = 0, this array is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,NSMP), if M > 0; +C LDU >= 1, if M = 0. +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,L) +C The leading NSMP-by-L part of this array must contain the +C t-by-l output-data sequence matrix Y, +C Y = [y_1 y_2 ... y_l]. Column j of Y contains the +C NSMP values of the j-th output component for consecutive +C time increments. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C The estimated initial state of the system, x(0). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for estimating the rank of +C matrices. If the user sets TOL > 0, then the given value +C of TOL is used as a lower bound for the reciprocal +C condition number; a matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then EPS is used +C instead, where EPS is the relative machine precision +C (see LAPACK Library routine DLAMCH). TOL <= 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains the reciprocal condition +C number of the triangular factor of the QR factorization of +C the matrix Gamma (see METHOD). +C On exit, if INFO = -22, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 2, min( LDW1, LDW2 ) ), where +C LDW1 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ), +C LDW2 = N*(N + 1) + 2*N + +C max( q*(N + 1) + 2*N*N + L*N, 4*N ), +C q = N*L. +C For good performance, LDWORK should be larger. +C If LDWORK >= LDW1, then standard QR factorization of +C the matrix Gamma (see METHOD) is used. Otherwise, the +C QR factorization is computed sequentially by performing +C NCYCLE cycles, each cycle (except possibly the last one) +C processing s samples, where s is chosen by equating +C LDWORK to LDW2, for q replaced by s*L. +C The computational effort may increase and the accuracy may +C decrease with the decrease of s. Recommended value is +C LDRWRK = LDW1, assuming a large enough cache size, to +C also accommodate A, B, C, D, U, and Y. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 4: the least squares problem to be solved has a +C rank-deficient coefficient matrix. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: the singular value decomposition (SVD) algorithm did +C not converge. +C +C METHOD +C +C An extension and refinement of the method in [1] is used. +C Specifically, the output y0(k) of the system for zero initial +C state is computed for k = 0, 1, ..., t-1 using the given model. +C Then the following least squares problem is solved for x(0) +C +C ( C ) ( y(0) - y0(0) ) +C ( C*A ) ( y(1) - y0(1) ) +C Gamma * x(0) = ( : ) * x(0) = ( : ). +C ( : ) ( : ) +C ( C*A^(t-1) ) ( y(t-1) - y0(t-1) ) +C +C The coefficient matrix Gamma is evaluated using powers of A with +C exponents 2^k. The QR decomposition of this matrix is computed. +C If its triangular factor R is too ill conditioned, then singular +C value decomposition of R is used. +C +C If the coefficient matrix cannot be stored in the workspace (i.e., +C LDWORK < LDW1), the QR decomposition is computed sequentially. +C +C REFERENCES +C +C [1] Verhaegen M., and Varga, A. +C Some Experience with the MOESP Class of Subspace Model +C Identification Methods in Identifying the BO105 Helicopter. +C Report TR R165-94, DLR Oberpfaffenhofen, 1994. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Identification methods; least squares solutions; multivariable +C systems; QR decomposition; singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C IBLOCK is a threshold value for switching to a block algorithm +C for U (to avoid row by row passing through U). + INTEGER IBLOCK + PARAMETER ( IBLOCK = 16384 ) +C .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, + $ LDWORK, LDY, M, N, NSMP + CHARACTER JOB +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *), + $ DWORK(*), U(LDU, *), X0(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION RCOND, TOLL + INTEGER I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON, + $ IG, INIGAM, INIH, INIR, INIT, IQ, IREM, IRHS, + $ ISIZE, ISV, ITAU, IU, IUPNT, IUT, IUTRAN, IX, + $ IXINIT, IY, IYPNT, J, JWORK, K, LDDW, LDR, + $ LDW1, LDW2, MAXWRK, MINSMP, MINWLS, MINWRK, NC, + $ NCP1, NCYCLE, NN, NOBS, NRBL, NROW, NSMPL, RANK + LOGICAL BLOCK, FIRST, NCYC, POWER2, SWITCH, WITHD +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY, + $ DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSV, + $ MA02AD, MB01TD, MB04OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, LOG, MAX, MIN, MOD +C .. Executable Statements .. +C +C Check the input parameters. +C + WITHD = LSAME( JOB, 'N' ) + IWARN = 0 + INFO = 0 + NN = N*N + MINSMP = N +C + IF( .NOT.( LSAME( JOB, 'Z' ) .OR. WITHD ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LE.0 ) THEN + INFO = -4 + ELSE IF( NSMP.LT.MINSMP ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.L ) THEN + INFO = -11 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) ) + $ THEN + INFO = -13 + ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN + INFO = -15 + ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -17 + ELSE IF( TOL.GT.ONE ) THEN + INFO = -19 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + NSMPL = NSMP*L + IQ = MINSMP*L + NCP1 = N + 1 + ISIZE = NSMPL*NCP1 + IC = 2*NN + MINWLS = MINSMP*NCP1 + ITAU = IC + L*N + LDW1 = ISIZE + 2*N + MAX( IC, 4*N ) + LDW2 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N ) + MINWRK = MAX( MIN( LDW1, LDW2 ), 2 ) + IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN + MAXWRK = ISIZE + 2*N + MAX( N*ILAENV( 1, 'DGEQRF', ' ', NSMPL, + $ N, -1, -1 ), + $ ILAENV( 1, 'DORMQR', 'LT', NSMPL, + $ 1, N, -1 ) ) + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF +C + IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN + INFO = -22 + DWORK(1) = MINWRK + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C +C Set up the least squares problem, either directly, if enough +C workspace, or sequentially, otherwise. +C + IYPNT = 1 + IUPNT = 1 + INIR = 1 + IF ( LDWORK.GE.LDW1 ) THEN +C +C Enough workspace for solving the problem directly. +C + NCYCLE = 1 + NOBS = NSMP + LDDW = NSMPL + INIGAM = 1 + ELSE +C +C NCYCLE > 1 cycles are needed for solving the problem +C sequentially, taking NOBS samples in each cycle (or the +C remaining samples in the last cycle). +C + JWORK = LDWORK - MINWLS - 2*N - ITAU + LDDW = JWORK/NCP1 + NOBS = LDDW/L + LDDW = L*NOBS + NCYCLE = NSMP/NOBS + IF ( MOD( NSMP, NOBS ).NE.0 ) + $ NCYCLE = NCYCLE + 1 + INIH = INIR + NN + INIGAM = INIH + N + END IF +C + NCYC = NCYCLE.GT.1 + IRHS = INIGAM + LDDW*N + IXINIT = IRHS + LDDW + IC = IXINIT + N + IF( NCYC ) THEN + IA = IC + L*N + LDR = N + IE = INIGAM + ELSE + INIH = IRHS + IA = IC + LDR = LDDW + IE = IXINIT + END IF + IUTRAN = IA + IAS = IA + NN + ITAU = IA + DUM(1) = ZERO +C +C Set block parameters for passing through the array U. +C + BLOCK = M.GT.1 .AND. NSMP*M.GE.IBLOCK + IF ( BLOCK ) THEN + NRBL = ( LDWORK - IUTRAN + 1 )/M + NC = NOBS/NRBL + IF ( MOD( NOBS, NRBL ).NE.0 ) + $ NC = NC + 1 + INIT = ( NC - 1 )*NRBL + BLOCK = BLOCK .AND. NRBL.GT.1 + END IF +C +C Perform direct of sequential compression of the matrix Gamma. +C + DO 150 ICYCLE = 1, NCYCLE + FIRST = ICYCLE.EQ.1 + IF ( .NOT.FIRST ) THEN + IF ( ICYCLE.EQ.NCYCLE ) THEN + NOBS = NSMP - ( NCYCLE - 1 )*NOBS + LDDW = L*NOBS + IF ( BLOCK ) THEN + NC = NOBS/NRBL + IF ( MOD( NOBS, NRBL ).NE.0 ) + $ NC = NC + 1 + INIT = ( NC - 1 )*NRBL + END IF + END IF + END IF +C +C Compute the extended observability matrix Gamma. +C Workspace: need s*L*(N + 1) + 2*N*N + 2*N + a + w, +C where s = NOBS, +C a = 0, w = 0, if NCYCLE = 1, +C a = L*N, w = N*(N + 1), if NCYCLE > 1; +C prefer as above, with s = t, a = w = 0. +C + JWORK = IAS + NN + IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) ) + IREM = L*( NOBS - 2**IEXPON ) + POWER2 = IREM.EQ.0 + IF ( .NOT.POWER2 ) + $ IEXPON = IEXPON + 1 +C + IF ( FIRST ) THEN + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(INIGAM), LDDW ) + ELSE + CALL DLACPY( 'Full', L, N, DWORK(IC), L, DWORK(INIGAM), + $ LDDW ) + END IF +C p +C Use powers of the matrix A: A , p = 2**(J-1). +C + CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N ) + IF ( N.GT.1 ) + $ CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 ) + I2 = L + NROW = 0 +C + DO 20 J = 1, IEXPON + IG = INIGAM + IF ( J.LT.IEXPON .OR. POWER2 ) THEN + NROW = I2 + ELSE + NROW = IREM + END IF +C + CALL DLACPY( 'Full', NROW, N, DWORK(IG), LDDW, DWORK(IG+I2), + $ LDDW ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', + $ NROW, N, ONE, DWORK(IA), N, DWORK(IG+I2), + $ LDDW ) +C p +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 10 IX = 1, N - 1 + CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), DWORK(IG+LDDW), + $ 1, DWORK(IG+I2), 1 ) + IG = IG + LDDW + 10 CONTINUE +C + IF ( J.LT.IEXPON ) THEN + CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), N ) + CALL DCOPY( N-1, DWORK(IA+1), N+1, DWORK(IAS+1), N+1 ) + CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N, + $ DWORK(JWORK), IERR ) + I2 = I2*2 + END IF + 20 CONTINUE +C + IF ( NCYC ) THEN + IG = INIGAM + I2 + NROW - L + CALL DLACPY( 'Full', L, N, DWORK(IG), LDDW, DWORK(IC), L ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', L, + $ N, ONE, A, LDA, DWORK(IC), L ) +C +C Compute the contribution of the subdiagonal of A to the +C product. +C + DO 30 IX = 1, N - 1 + CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), 1, + $ DWORK(IC+(IX-1)*L), 1 ) + IG = IG + LDDW + 30 CONTINUE +C + END IF +C +C Setup (part of) the right hand side of the least squares +C problem starting from DWORK(IRHS); use the estimated output +C trajectory for zero initial state, or for the saved final state +C value of the previous cycle. +C A specialization of SLICOT Library routine TF01ND is used. +C For large input sets (NSMP*M >= IBLOCK), chunks of U are +C transposed, to reduce the number of row-wise passes. +C Workspace: need s*L*(N + 1) + N + w; +C prefer as above, with s = t, w = 0. +C + IF ( FIRST ) + $ CALL DCOPY( N, DUM, 0, DWORK(IXINIT), 1 ) + CALL DCOPY( N, DWORK(IXINIT), 1, X0, 1 ) + IY = IRHS +C + DO 40 J = 1, L + CALL DCOPY( NOBS, Y(IYPNT,J), 1, DWORK(IY), L ) + IY = IY + 1 + 40 CONTINUE +C + IY = IRHS + IU = IUPNT + IF ( M.GT.0 ) THEN + IF ( WITHD ) THEN +C + IF ( BLOCK ) THEN + SWITCH = .TRUE. + NROW = NRBL +C + DO 60 K = 1, NOBS + IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN + IUT = IUTRAN + IF ( K.GT.INIT ) THEN + NROW = NOBS - INIT + SWITCH = .FALSE. + END IF + CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, + $ DWORK(IUT), M ) + IU = IU + NROW + END IF + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, + $ DWORK(IUT), 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 50 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 50 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ DWORK(IUT), 1, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IUT = IUT + M + 60 CONTINUE +C + ELSE +C + DO 80 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD, + $ U(IU,1), LDU, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 70 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 70 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IU,1), LDU, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IU = IU + 1 + 80 CONTINUE +C + END IF +C + ELSE +C + IF ( BLOCK ) THEN + SWITCH = .TRUE. + NROW = NRBL +C + DO 100 K = 1, NOBS + IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN + IUT = IUTRAN + IF ( K.GT.INIT ) THEN + NROW = NOBS - INIT + SWITCH = .FALSE. + END IF + CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU, + $ DWORK(IUT), M ) + IU = IU + NROW + END IF + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 90 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 90 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ DWORK(IUT), 1, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IUT = IUT + M + 100 CONTINUE +C + ELSE +C + DO 120 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, + $ 1, ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, + $ A, LDA, X0, 1 ) +C + DO 110 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 110 CONTINUE +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IU,1), LDU, ONE, X0, 1 ) + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + IU = IU + 1 + 120 CONTINUE +C + END IF +C + END IF +C + ELSE +C + DO 140 K = 1, NOBS + CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, 1, + $ ONE, DWORK(IY), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, A, + $ LDA, X0, 1 ) +C + DO 130 IX = 2, N + X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2) + 130 CONTINUE +C + CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 ) + IY = IY + L + 140 CONTINUE +C + END IF +C +C Compress the data using (sequential) QR factorization. +C Workspace: need v + 2*N; +C where v = s*L*(N + 1) + N + a + w. +C + JWORK = ITAU + N + IF ( FIRST ) THEN +C +C Compress the first data segment of Gamma. +C Workspace: need v + 2*N, +C prefer v + N + N*NB. +C + CALL DGEQRF( LDDW, N, DWORK(INIGAM), LDDW, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C +C Apply the transformation to the right hand side part. +C Workspace: need v + N + 1, +C prefer v + N + NB. +C + CALL DORMQR( 'Left', 'Transpose', LDDW, 1, N, DWORK(INIGAM), + $ LDDW, DWORK(ITAU), DWORK(IRHS), LDDW, + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) +C + IF ( NCYC ) THEN +C +C Save the triangular factor of Gamma and the +C corresponding right hand side. +C + CALL DLACPY( 'Upper', N, NCP1, DWORK(INIGAM), LDDW, + $ DWORK(INIR), LDR ) + END IF + ELSE +C +C Compress the current (but not the first) data segment of +C Gamma. +C Workspace: need v + N - 1. +C + CALL MB04OD( 'Full', N, 1, LDDW, DWORK(INIR), LDR, + $ DWORK(INIGAM), LDDW, DWORK(INIH), LDR, + $ DWORK(IRHS), LDDW, DWORK(ITAU), DWORK(JWORK) ) + END IF +C + IUPNT = IUPNT + NOBS + IYPNT = IYPNT + NOBS + 150 CONTINUE +C +C Estimate the reciprocal condition number of the triangular factor +C of the QR decomposition. +C Workspace: need u + 3*N, where +C u = t*L*(N + 1), if NCYCLE = 1; +C u = w, if NCYCLE > 1. +C + CALL DTRCON( '1-norm', 'Upper', 'No Transpose', N, DWORK(INIR), + $ LDR, RCOND, DWORK(IE), IWORK, IERR ) +C + TOLL = TOL + IF ( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN + IWARN = 4 +C +C The least squares problem is ill-conditioned. +C Use SVD to solve it. +C Workspace: need u + 6*N; +C prefer larger. +C + CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, DWORK(INIR+1), + $ LDR ) + ISV = IE + JWORK = ISV + N + CALL DGELSS( N, N, 1, DWORK(INIR), LDR, DWORK(INIH), LDR, + $ DWORK(ISV), TOLL, RANK, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( IERR.GT.0 ) THEN +C +C Return if SVD algorithm did not converge. +C + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 ) + ELSE +C +C Find the least squares solution using QR decomposition only. +C + CALL DTRSV( 'Upper', 'No Transpose', 'Non Unit', N, + $ DWORK(INIR), LDR, DWORK(INIH), 1 ) + END IF +C +C Return the estimated initial state of the system x0. +C + CALL DCOPY( N, DWORK(INIH), 1, X0, 1 ) +C + DWORK(1) = MAXWRK + DWORK(2) = RCOND +C + RETURN +C +C *** End of IB01RD *** + END diff --git a/mex/sources/libslicot/IB03AD.f b/mex/sources/libslicot/IB03AD.f new file mode 100644 index 000000000..9ba63187c --- /dev/null +++ b/mex/sources/libslicot/IB03AD.f @@ -0,0 +1,1076 @@ + SUBROUTINE IB03AD( INIT, ALG, STOR, NOBR, M, L, NSMP, N, NN, + $ ITMAX1, ITMAX2, NPRINT, U, LDU, Y, LDY, X, LX, + $ TOL1, TOL2, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a set of parameters for approximating a Wiener system +C in a least-squares sense, using a neural network approach and a +C Levenberg-Marquardt algorithm. Conjugate gradients (CG) or +C Cholesky algorithms are used to solve linear systems of equations. +C The Wiener system is represented as +C +C x(t+1) = A*x(t) + B*u(t) +C z(t) = C*x(t) + D*u(t), +C +C y(t) = f(z(t),wb(1:L)), +C +C where t = 1, 2, ..., NSMP, and f is a nonlinear function, +C evaluated by the SLICOT Library routine NF01AY. The parameter +C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), +C where wb(i), i = 1 : L, correspond to the nonlinear part, and +C theta corresponds to the linear part. See SLICOT Library routine +C NF01AD for further details. +C +C The sum of squares of the error functions, defined by +C +C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, +C +C is minimized, where Y(t) is the measured output vector. The +C functions and their Jacobian matrices are evaluated by SLICOT +C Library routine NF01BB (the FCN routine in the call of MD03AD). +C +C ARGUMENTS +C +C Mode Parameters +C +C INIT CHARACTER*1 +C Specifies which parts have to be initialized, as follows: +C = 'L' : initialize the linear part only, X already +C contains an initial approximation of the +C nonlinearity; +C = 'S' : initialize the static nonlinearity only, X +C already contains an initial approximation of the +C linear part; +C = 'B' : initialize both linear and nonlinear parts; +C = 'N' : do not initialize anything, X already contains +C an initial approximation. +C If INIT = 'S' or 'B', the error functions for the +C nonlinear part, and their Jacobian matrices, are evaluated +C by SLICOT Library routine NF01BA (used as a second FCN +C routine in the MD03AD call for the initialization step, +C see METHOD). +C +C ALG CHARACTER*1 +C Specifies the algorithm used for solving the linear +C systems involving a Jacobian matrix J, as follows: +C = 'D' : a direct algorithm, which computes the Cholesky +C factor of the matrix J'*J + par*I is used, where +C par is the Levenberg factor; +C = 'I' : an iterative Conjugate Gradients algorithm, which +C only needs the matrix J, is used. +C In both cases, matrix J is stored in a compressed form. +C +C STOR CHARACTER*1 +C If ALG = 'D', specifies the storage scheme for the +C symmetric matrix J'*J, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C The option STOR = 'F' usually ensures a faster execution. +C This parameter is not relevant if ALG = 'I'. +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C If INIT = 'L' or 'B', NOBR is the number of block rows, s, +C in the input and output block Hankel matrices to be +C processed for estimating the linear part. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, +C the estimated dimension of state vector.) +C This parameter is ignored if INIT is 'S' or 'N'. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L >= 0, and L > 0, if +C INIT = 'L' or 'B'. +C +C NSMP (input) INTEGER +C The number of input and output samples, t. NSMP >= 0, and +C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. +C +C N (input/output) INTEGER +C The order of the linear part. +C If INIT = 'L' or 'B', and N < 0 on entry, the order is +C assumed unknown and it will be found by the routine. +C Otherwise, the input value will be used. If INIT = 'S' +C or 'N', N must be non-negative. The values N >= NOBR, +C or N = 0, are not acceptable if INIT = 'L' or 'B'. +C +C NN (input) INTEGER +C The number of neurons which shall be used to approximate +C the nonlinear part. NN >= 0. +C +C ITMAX1 (input) INTEGER +C The maximum number of iterations for the initialization of +C the static nonlinearity. +C This parameter is ignored if INIT is 'N' or 'L'. +C Otherwise, ITMAX1 >= 0. +C +C ITMAX2 (input) INTEGER +C The maximum number of iterations. ITMAX2 >= 0. +C +C NPRINT (input) INTEGER +C This parameter enables controlled printing of iterates if +C it is positive. In this case, FCN is called with IFLAG = 0 +C at the beginning of the first iteration and every NPRINT +C iterations thereafter and immediately prior to return, +C and the current error norm is printed. Other intermediate +C results could be printed by modifying the corresponding +C FCN routine (NF01BA and/or NF01BB). If NPRINT <= 0, no +C special calls of FCN with IFLAG = 0 are made. +C +C U (input) DOUBLE PRECISION array, dimension (LDU, M) +C The leading NSMP-by-M part of this array must contain the +C set of input samples, +C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NSMP). +C +C Y (input) DOUBLE PRECISION array, dimension (LDY, L) +C The leading NSMP-by-L part of this array must contain the +C set of output samples, +C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,NSMP). +C +C X (input/output) DOUBLE PRECISION array dimension (LX) +C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part +C of this array must contain the initial parameters for +C the nonlinear part of the system. +C On entry, if INIT = 'S', the elements lin1 : lin2 of this +C array must contain the initial parameters for the linear +C part of the system, corresponding to the output normal +C form, computed by SLICOT Library routine TB01VD, where +C lin1 = (NN*(L+2) + 1)*L + 1; +C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. +C On entry, if INIT = 'N', the elements 1 : lin2 of this +C array must contain the initial parameters for the +C nonlinear part followed by the initial parameters for the +C linear part of the system, as specified above. +C This array need not be set on entry if INIT = 'B'. +C On exit, the elements 1 : lin2 of this array contain the +C optimal parameters for the nonlinear part followed by the +C optimal parameters for the linear part of the system, as +C specified above. +C +C LX (input/output) INTEGER +C On entry, this parameter must contain the intended length +C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). +C If N is unknown (N < 0 on entry), a large enough estimate +C of N should be used in the formula of lin2. +C On exit, if N < 0 on entry, but LX is not large enough, +C then this parameter contains the actual length of X, +C corresponding to the computed N. Otherwise, its value +C is unchanged. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance +C which measures the relative error desired in the sum of +C squares, for the initialization step of nonlinear part. +C Termination occurs when the actual relative reduction in +C the sum of squares is at most TOL1. In addition, if +C ALG = 'I', TOL1 also measures the relative residual of +C the solutions computed by the CG algorithm (for the +C initialization step). Termination of a CG process occurs +C when the relative residual is at most TOL1. +C If the user sets TOL1 < 0, then SQRT(EPS) is used +C instead TOL1, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). +C This parameter is ignored if INIT is 'N' or 'L'. +C +C TOL2 DOUBLE PRECISION +C If TOL2 >= 0, TOL2 is the tolerance which measures the +C relative error desired in the sum of squares, for the +C whole optimization process. Termination occurs when the +C actual relative reduction in the sum of squares is at +C most TOL2. +C If ALG = 'I', TOL2 also measures the relative residual of +C the solutions computed by the CG algorithm (for the whole +C optimization). Termination of a CG process occurs when the +C relative residual is at most TOL2. +C If the user sets TOL2 < 0, then SQRT(EPS) is used +C instead TOL2. This default value could require many +C iterations, especially if TOL1 is larger. If INIT = 'S' +C or 'B', it is advisable that TOL2 be larger than TOL1, +C and spend more time with cheaper iterations. +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX( 3, LIW1, LIW2 )), where +C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, +C LIW1 = M+L; +C LIW2 = MAX(M*NOBR+N,M*(N+L)). +C On output, if INFO = 0, IWORK(1) and IWORK(2) return the +C (total) number of function and Jacobian evaluations, +C respectively (including the initialization step, if it was +C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) +C specifies how many locations of DWORK contain reciprocal +C condition number estimates (see below); otherwise, +C IWORK(3) = 0. +C +C DWORK DOUBLE PRECISION array dimesion (LDWORK) +C On entry, if desired, and if INIT = 'S' or 'B', the +C entries DWORK(1:4) are set to initialize the random +C numbers generator for the nonlinear part parameters (see +C the description of the argument XINIT of SLICOT Library +C routine MD03AD); this enables to obtain reproducible +C results. The same seed is used for all outputs. +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the residual error norm (the +C sum of squares), DWORK(3) returns the number of iterations +C performed, DWORK(4) returns the number of conjugate +C gradients iterations performed, and DWORK(5) returns the +C final Levenberg factor, for optimizing the parameters of +C both the linear part and the static nonlinearity part. +C If INIT = 'S' or INIT = 'B' and INFO = 0, then the +C elements DWORK(6) to DWORK(10) contain the corresponding +C five values for the initialization step (see METHOD). +C (If L > 1, DWORK(10) contains the maximum of the Levenberg +C factors for all outputs.) If INIT = 'L' or INIT = 'B', and +C INFO = 0, DWORK(11) to DWORK(10+IWORK(3)) contain +C reciprocal condition number estimates set by SLICOT +C Library routines IB01AD, IB01BD, and IB01CD. +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C In the formulas below, N should be taken not larger than +C NOBR - 1, if N < 0 on entry. +C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where +C LW1 = 0, if INIT = 'S' or 'N'; otherwise, +C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, +C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + +C MAX( LDW1, LDW2 ), +C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + +C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), +C where, +C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, +C L*NOBR*N + +C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) +C LDW2 >= 0, if M = 0; +C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + +C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; +C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), +C LDW4 = N*(N+1) + 2*N + +C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); +C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; +C LDW6 = NSMP*L + (N+L)*(N+M) + N + +C MAX(1, N*N*L + N*L + N, N*N + +C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), +C N*M)); +C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, +C LW2 = NSMP*L + +C MAX( 5, NSMP + 2*BSN + NSMP*BSN + +C MAX( 2*NN + BSN, LDW7 ) ); +C LDW7 = BSN*BSN, if ALG = 'D' and STOR = 'F'; +C LDW7 = BSN*(BSN+1)/2, if ALG = 'D' and STOR = 'P'; +C LDW7 = 3*BSN + NSMP, if ALG = 'I'; +C LW3 = MAX( LDW8, NSMP*L + (N+L)*(2*N+M) + 2*N ); +C LDW8 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; +C LDW8 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; +C LW4 = MAX( 5, NSMP*L + 2*NX + NSMP*L*( BSN + LTHS ) + +C MAX( L1 + NX, NSMP*L + L1, L2 ) ), +C L0 = MAX( N*(N+L), N+M+L ), if M > 0; +C L0 = MAX( N*(N+L), L ), if M = 0; +C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); +C L2 = NX*NX, if ALG = 'D' and STOR = 'F'; +C L2 = NX*(NX+1)/2, if ALG = 'D' and STOR = 'P'; +C L2 = 3*NX + NSMP*L, if ALG = 'I', +C with BSN = NN*( L + 2 ) + 1, +C LTHS = N*( L + M + 1 ) + L*M. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C < 0: the user set IFLAG = IWARN in (one of) the +C subroutine(s) FCN, i.e., NF01BA, if INIT = 'S' +C or 'B', and/or NF01BB; this value cannot be returned +C without changing the FCN routine(s); +C otherwise, IWARN has the value k*100 + j*10 + i, +C where k is defined below, i refers to the whole +C optimization process, and j refers to the +C initialization step (j = 0, if INIT = 'L' or 'N'), +C and the possible values for i and j have the +C following meaning (where TOL* denotes TOL1 or TOL2, +C and similarly for ITMAX*): +C = 1: the number of iterations has reached ITMAX* without +C satisfying the convergence condition; +C = 2: if alg = 'I' and in an iteration of the Levenberg- +C Marquardt algorithm, the CG algorithm finished +C after 3*NX iterations (or 3*(lin1-1) iterations, for +C the initialization phase), without achieving the +C precision required in the call; +C = 3: the cosine of the angle between the vector of error +C function values and any column of the Jacobian is at +C most FACTOR*EPS in absolute value (FACTOR = 100); +C = 4: TOL* is too small: no further reduction in the sum +C of squares is possible. +C The digit k is normally 0, but if INIT = 'L' or 'B', it +C can have a value in the range 1 to 6 (see IB01AD, IB01BD +C and IB01CD). In all these cases, the entries DWORK(1:5), +C DWORK(6:10) (if INIT = 'S' or 'B'), and +C DWORK(11:10+IWORK(3)) (if INIT = 'L' or 'B'), are set as +C described above. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C otherwise, INFO has the value k*100 + j*10 + i, +C where k is defined below, i refers to the whole +C optimization process, and j refers to the +C initialization step (j = 0, if INIT = 'L' or 'N'), +C and the possible values for i and j have the +C following meaning: +C = 1: the routine FCN returned with INFO <> 0 for +C IFLAG = 1; +C = 2: the routine FCN returned with INFO <> 0 for +C IFLAG = 2; +C = 3: ALG = 'D' and SLICOT Library routines MB02XD or +C NF01BU (or NF01BV, if INIT = 'S' or 'B') or +C ALG = 'I' and SLICOT Library routines MB02WD or +C NF01BW (or NF01BX, if INIT = 'S' or 'B') returned +C with INFO <> 0. +C In addition, if INIT = 'L' or 'B', i could also be +C = 4: if a Lyapunov equation could not be solved; +C = 5: if the identified linear system is unstable; +C = 6: if the QR algorithm failed on the state matrix +C of the identified linear system. +C The digit k is normally 0, but if INIT = 'L' or 'B', it +C can have a value in the range 1 to 10 (see IB01AD/IB01BD). +C +C METHOD +C +C If INIT = 'L' or 'B', the linear part of the system is +C approximated using the combined MOESP and N4SID algorithm. If +C necessary, this algorithm can also choose the order, but it is +C advantageous if the order is already known. +C +C If INIT = 'S' or 'B', the output of the approximated linear part +C is computed and used to calculate an approximation of the static +C nonlinearity using the Levenberg-Marquardt algorithm [1]. +C This step is referred to as the (nonlinear) initialization step. +C +C As last step, the Levenberg-Marquardt algorithm is used again to +C optimize the parameters of the linear part and the static +C nonlinearity as a whole. Therefore, it is necessary to parametrise +C the matrices of the linear part. The output normal form [2] +C parameterisation is used. +C +C The Jacobian is computed analytically, for the nonlinear part, and +C numerically, for the linear part. +C +C REFERENCES +C +C [1] Kelley, C.T. +C Iterative Methods for Optimization. +C Society for Industrial and Applied Mathematics (SIAM), +C Philadelphia (Pa.), 1999. +C +C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. +C Balanced realizations of discrete-time stable all-pass +C systems and the tangential Schur algorithm. +C Proceedings of the European Control Conference, +C 31 August - 3 September 1999, Karlsruhe, Germany. +C Session CP-6, Discrete-time Systems, 1999. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Mar. 2002, Apr. 2002, Feb. 2004, March 2005, Nov. 2005. +C +C KEYWORDS +C +C Conjugate gradients, least-squares approximation, +C Levenberg-Marquardt algorithm, matrix operations, optimization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C The upper triangular part is used in MD03AD; + CHARACTER UPLO + PARAMETER ( UPLO = 'U' ) +C For INIT = 'L' or 'B', additional parameters are set: +C The following six parameters are used in the call of IB01AD; + CHARACTER IALG, BATCH, CONCT, CTRL, JOBD, METH + PARAMETER ( IALG = 'Fast QR', BATCH = 'One batch', + $ CONCT = 'Not connect', CTRL = 'Not confirm', + $ JOBD = 'Not MOESP', METH = 'MOESP' ) +C The following three parameters are used in the call of IB01BD; + CHARACTER JOB, JOBCK, METHB + PARAMETER ( JOB = 'All matrices', + $ JOBCK = 'No Kalman gain', + $ METHB = 'Combined MOESP+N4SID' ) +C The following two parameters are used in the call of IB01CD; + CHARACTER COMUSE, JOBXD + PARAMETER ( COMUSE = 'Use B, D', + $ JOBXD = 'D also' ) +C TOLN controls the estimated order in IB01AD (default value); + DOUBLE PRECISION TOLN + PARAMETER ( TOLN = -1.0D0 ) +C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD +C (default); + DOUBLE PRECISION RCOND + PARAMETER ( RCOND = -1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ALG, INIT, STOR + INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, + $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + INTEGER AC, BD, BSN, I, IA, IB, IK, INFOL, IQ, IR, + $ IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, IW2, + $ IWARNL, IX, IX0, J, JWORK, LDAC, LDR, LIPAR, + $ LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, NSML, + $ NTHS, NX, WRKOPT, Z + LOGICAL CHOL, FULL, INIT1, INIT2 +C .. Local Arrays .. + LOGICAL BWORK(1) + INTEGER IPAR(7) + DOUBLE PRECISION RCND(16), SEED(4), WORK(5) +C .. External Functions .. + EXTERNAL LSAME + LOGICAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03AD, NF01BA, + $ NF01BB, NF01BU, NF01BV, NF01BW, NF01BX, TB01VD, + $ TB01VY, TF01MX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. +C .. Executable Statements .. +C + CHOL = LSAME( ALG, 'D' ) + FULL = LSAME( STOR, 'F' ) + INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) + INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) +C + ML = M + L + INFO = 0 + IWARN = 0 + IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN + INFO = -2 + ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -3 + ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN + INFO = -4 + ELSEIF ( M.LT.0 ) THEN + INFO = -5 + ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN + INFO = -6 + ELSEIF ( NSMP.LT.0 .OR. + $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN + INFO = -7 + ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. + $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN + INFO = -8 + ELSEIF ( NN.LT.0 ) THEN + INFO = -9 + ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN + INFO = -10 + ELSEIF ( ITMAX2.LT.0 ) THEN + INFO = -11 + ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN + INFO = -14 + ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -16 + ELSE + LNOL = L*NOBR - L + MNO = M*NOBR + BSN = NN*( L + 2 ) + 1 + NTHS = BSN*L + NSML = NSMP*L + IF ( N.GT.0 ) THEN + LDAC = N + L + ISAD = LDAC*( N + M ) + N2 = N*N + END IF +C +C Check the workspace size. +C + JWORK = 0 + IF ( INIT1 ) THEN +C Workspace for IB01AD. + JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR + IF ( N.GT.0 ) THEN +C Workspace for IB01BD. + IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, + $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + + $ 1, MNO + 3*N + L ) ) + IF ( M.GT.0 ) THEN + IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + + $ MAX( LDAC**2, 4*M*LDAC + 1 ) + ELSE + IW2 = 0 + END IF + JWORK = MAX( JWORK, + $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) +C Workspace for IB01CD. + IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) + IW2 = N*( N + 1 ) + 2*N + + $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) + JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) +C Workspace for TF01MX. + JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) +C Workspace for TB01VD. + JWORK = MAX( JWORK, NSML + ISAD + N + + $ MAX( 1, N2*L + N*L + N, + $ N2 + MAX( N2 + N*MAX( N, L ) + + $ 6*N + MIN( N, L ), N*M ) ) ) + END IF + END IF +C + IF ( INIT2 ) THEN +C Workspace for MD03AD (initialization of the nonlinear part). + IF ( CHOL ) THEN + IF ( FULL ) THEN + IW1 = BSN**2 + ELSE + IW1 = ( BSN*( BSN + 1 ) )/2 + END IF + ELSE + IW1 = 3*BSN + NSMP + END IF + JWORK = MAX( JWORK, NSML + + $ MAX( 5, NSMP + 2*BSN + NSMP*BSN + + $ MAX( 2*NN + BSN, IW1 ) ) ) + IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN +C Workspace for TB01VY. + JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) +C Workspace for TF01MX. + IF ( M.GT.0 ) THEN + IW1 = N + M + ELSE + IW1 = 0 + END IF + JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) + END IF + END IF +C + IF ( N.GE.0 ) THEN +C +C Find the number of parameters. +C + LTHS = N*( ML + 1 ) + L*M + NX = NTHS + LTHS +C + IF ( LX.LT.NX ) THEN + INFO = -18 + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF +C +C Workspace for MD03AD (whole optimization). +C + IF ( M.GT.0 ) THEN + IW1 = LDAC + M + ELSE + IW1 = L + END IF + IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) + IF ( CHOL ) THEN + IF ( FULL ) THEN + IW2 = NX**2 + ELSE + IW2 = ( NX*( NX + 1 ) )/2 + END IF + ELSE + IW2 = 3*NX + NSML + END IF + JWORK = MAX( JWORK, + $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + + $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) + END IF +C + IF ( LDWORK.LT.JWORK ) THEN + INFO = -23 + DWORK(1) = JWORK + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + ENDIF +C +C Initialize the pointers to system matrices and save the possible +C seed for random numbers generation. +C + Z = 1 + AC = Z + NSML + CALL DCOPY( 4, DWORK, 1, SEED, 1 ) +C + WRKOPT = 1 +C + IF ( INIT1 ) THEN +C +C Initialize the linear part. +C If N < 0, the order of the system is determined by IB01AD; +C otherwise, the given order will be used. +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; +C prefer: larger. +C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) +C + NS = N + IR = 1 + ISV = 2*ML*NOBR + LDR = ISV + IF ( LSAME( JOBD, 'M' ) ) + $ LDR = MAX( LDR, 3*MNO ) + ISV = IR + LDR*ISV + JWORK = ISV + L*NOBR +C + CALL IB01AD( METH, IALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, + $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, + $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARNL, INFOL ) +C + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCND = 0 + IF ( LSAME( METH, 'N' ) ) THEN + IRCND = 2 + CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) + END IF +C + IF ( NS.GE.0 ) THEN + N = NS + ELSE +C +C Find the number of parameters. +C + LDAC = N + L + ISAD = LDAC*( N + M ) + N2 = N*N + LTHS = N*( ML + 1 ) + L*M + NX = NTHS + LTHS +C + IF ( LX.LT.NX ) THEN + LX = NX + INFO = -18 + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF +C Workspace for IB01BD. + IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, + $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, + $ MNO + 3*N + L ) ) + IF ( M.GT.0 ) THEN + IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + + $ MAX( LDAC**2, 4*M*LDAC + 1 ) + ELSE + IW2 = 0 + END IF + JWORK = ISV + ISAD + MAX( IW1, IW2 ) +C Workspace for IB01CD. + IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) + IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, + $ 4*N ) + JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) +C Workspace for TF01MX. + JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) +C Workspace for TB01VD. + JWORK = MAX( JWORK, NSML + ISAD + N + + $ MAX( 1, N2*L + N*L + N, + $ N2 + MAX( N2 + N*MAX( N, L ) + + $ 6*N + MIN( N, L ), N*M ) ) ) +C Workspace for MD03AD (whole optimization). + IF ( M.GT.0 ) THEN + IW1 = LDAC + M + ELSE + IW1 = L + END IF + IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) + IF ( CHOL ) THEN + IF ( FULL ) THEN + IW2 = NX**2 + ELSE + IW2 = ( NX*( NX + 1 ) )/2 + END IF + ELSE + IW2 = 3*NX + NSML + END IF + JWORK = MAX( JWORK, + $ 5, NSML + 2*NX + NSML*( BSN + LTHS ) + + $ MAX( IW1 + NX, NSML + IW1, IW2 ) ) + IF ( LDWORK.LT.JWORK ) THEN + INFO = -23 + DWORK(1) = JWORK + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF + END IF +C + BD = AC + LDAC*N + IX = BD + LDAC*M + IA = ISV + IB = IA + LDAC*N + IQ = IB + LDAC*M + IF ( LSAME( JOBCK, 'N' ) ) THEN + IRY = IQ + IS = IQ + IK = IQ + JWORK = IQ + ELSE + IRY = IQ + N2 + IS = IRY + L*L + IK = IS + N*L + JWORK = IK + N*L + END IF +C +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: +C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + +C max( LDW1,LDW2 ), where, +C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, +C L*NOBR*N + +C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) +C LDW2 >= 0, if M = 0; +C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ +C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; +C prefer: larger. +C Integer workspace: MAX(M*NOBR+N,M*(N+L)). +C + CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), + $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, + $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, + $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, + $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, + $ IWARNL, INFOL ) +C + IF( INFOL.EQ.-30 ) THEN + INFO = -23 + DWORK(1) = DWORK(JWORK) + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCNDB = 4 + IF ( LSAME( JOBCK, 'K' ) ) + $ IRCNDB = IRCNDB + 8 + CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) + IRCND = IRCND + IRCNDB +C +C Copy the system matrices to the beginning of DWORK, to save +C space, and redefine the pointers. +C + CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) + IA = 1 + IB = IA + LDAC*N + IX0 = IB + LDAC*M + IV = IX0 + N +C +C Compute the initial condition of the system. On normal exit, +C DWORK(i), i = JWORK+2:JWORK+1+N*N, +C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and +C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, +C contain the transformed system matrices At, Ct, and Bt, +C respectively, corresponding to the real Schur form of the +C estimated system state matrix A. The transformation matrix is +C stored in DWORK(IV:IV+N*N-1). +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: +C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + +C max( 5*N, 2, min( LDW1, LDW2 ) ), where, +C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), +C LDW2 = N*(N + 1) + 2*N + +C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); +C prefer: larger. +C Integer workspace: N. +C + JWORK = IV + N2 + CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, + $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), + $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, + $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) +C + IF( INFOL.EQ.-26 ) THEN + INFO = -23 + DWORK(1) = DWORK(JWORK) + CALL XERBLA( 'IB03AD', -INFO ) + RETURN + END IF + IF( INFOL.EQ.1 ) + $ INFOL = 10 + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCND = IRCND + 1 + RCND(IRCND) = DWORK(JWORK+1) +C +C Now, save the system matrices and x0 in the final location. +C + IF ( IV.LT.AC ) THEN + CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) + ELSE + DO 5 J = AC + ISAD + N - 1, AC, -1 + DWORK(J) = DWORK(IA+J-AC) + 5 CONTINUE + END IF +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + JWORK = IX + N + CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), + $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) +C +C Convert the state-space representation to output normal form. +C Workspace: +C need: NSMP*L + (N + L)*(N + M) + N + +C MAX(1, N*N*L + N*L + N, N*N + +C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); +C prefer: larger. +C + CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), + $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, + $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), + $ LDWORK-JWORK+1, INFOL ) +C + IF( INFOL.GT.0 ) THEN + INFO = INFOL + 3 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + END IF +C + LIPAR = 7 + IW1 = 0 + IW2 = 0 +C + IF ( INIT2 ) THEN +C +C Initialize the nonlinear part. +C + IF ( .NOT.INIT1 ) THEN + BD = AC + LDAC*N + IX = BD + LDAC*M +C +C Convert the output normal form to state-space model. +C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. +C (NSMP*L locations are reserved for the output of the linear +C part.) +C + JWORK = IX + N + CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), + $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, + $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, + $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + END IF +C +C Optimize the parameters of the nonlinear part. +C Workspace: +C need NSMP*L + +C MAX( 5, NSMP + 2*BSN + NSMP*BSN + +C MAX( 2*NN + BSN, DW( sol ) ) ), +C where, if ALG = 'D', +C DW( sol ) = BSN*BSN, if STOR = 'F'; +C DW( sol ) = BSN*(BSN+1)/2, if STOR = 'P'; +C and DW( sol ) = 3*BSN + NSMP, if ALG = 'I'; +C prefer larger. +C + JWORK = AC + WORK(1) = ZERO + CALL DCOPY( 4, WORK(1), 0, WORK(2), 1 ) +C +C Set the integer parameters needed, including the number of +C neurons. +C + IPAR(1) = NSMP + IPAR(2) = L + IPAR(3) = NN +C + DO 10 I = 0, L - 1 + CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) + IF ( CHOL ) THEN + CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, + $ NF01BA, NF01BV, NSMP, BSN, ITMAX1, NPRINT, + $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, + $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, + $ INFOL ) + ELSE + CALL MD03AD( 'Random initialization', ALG, STOR, UPLO, + $ NF01BA, NF01BX, NSMP, BSN, ITMAX1, NPRINT, + $ IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), LDY, + $ X(I*BSN+1), NFEV, NJEV, TOL1, TOL1, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, + $ INFOL ) + END IF +C + IF( INFOL.NE.0 ) THEN + INFO = 10*INFOL + RETURN + END IF + IF ( IWARNL.LT.0 ) THEN + INFO = INFOL + IWARN = IWARNL + GO TO 20 + ELSEIF ( IWARNL.GT.0 ) THEN + IF ( IWARN.GT.100 ) THEN + IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) + ELSE + IWARN = MAX( IWARN, 10*IWARNL ) + END IF + END IF + WORK(1) = MAX( WORK(1), DWORK(JWORK) ) + WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) + WORK(5) = MAX( WORK(5), DWORK(JWORK+4) ) + WORK(3) = WORK(3) + DWORK(JWORK+2) + WORK(4) = WORK(4) + DWORK(JWORK+3) + IW1 = NFEV + IW1 + IW2 = NJEV + IW2 + 10 CONTINUE +C + ENDIF +C +C Main iteration. +C Workspace: need MAX( 5, NFUN + 2*NX + NFUN*( BSN + LTHS ) + +C MAX( LDW1 + NX, NFUN + LDW1, DW( sol ) ) ), +C where NFUN = NSMP*L, and +C LDW1 = NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L )), +C if M > 0, +C LDW1 = NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), +C if M = 0; +C if ALG = 'D', +C DW( sol ) = NX*NX, if STOR = 'F'; +C DW( sol ) = NX*(NX+1)/2, if STOR = 'P'; +C and DW( sol ) = 3*NX + NFUN, if ALG = 'I', +C and DW( f ) is the workspace needed by the +C subroutine f; +C prefer larger. +C +C Set the integer parameters describing the Jacobian structure +C and the number of neurons. +C + IPAR(1) = LTHS + IPAR(2) = L + IPAR(3) = NSMP + IPAR(4) = BSN + IPAR(5) = M + IPAR(6) = N + IPAR(7) = NN +C + IF ( CHOL ) THEN + CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, + $ NF01BU, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, + $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, + $ DWORK, LDWORK, IWARNL, INFO ) + ELSE + CALL MD03AD( 'Given initialization', ALG, STOR, UPLO, NF01BB, + $ NF01BW, NSML, NX, ITMAX2, NPRINT, IPAR, LIPAR, + $ U, LDU, Y, LDY, X, NFEV, NJEV, TOL2, TOL2, + $ DWORK, LDWORK, IWARNL, INFO ) + END IF +C + IF( INFO.NE.0 ) + $ RETURN +C + 20 CONTINUE + IWORK(1) = IW1 + NFEV + IWORK(2) = IW2 + NJEV + IF ( IWARNL.LT.0 ) THEN + IWARN = IWARNL + ELSE + IWARN = IWARN + IWARNL + END IF + IF ( INIT2 ) + $ CALL DCOPY( 5, WORK, 1, DWORK(6), 1 ) + IF ( INIT1 ) THEN + IWORK(3) = IRCND + CALL DCOPY( IRCND, RCND, 1, DWORK(11), 1 ) + ELSE + IWORK(3) = 0 + END IF + RETURN +C +C *** Last line of IB03AD *** + END diff --git a/mex/sources/libslicot/IB03BD.f b/mex/sources/libslicot/IB03BD.f new file mode 100644 index 000000000..a1e0e86de --- /dev/null +++ b/mex/sources/libslicot/IB03BD.f @@ -0,0 +1,1087 @@ + SUBROUTINE IB03BD( INIT, NOBR, M, L, NSMP, N, NN, ITMAX1, ITMAX2, + $ NPRINT, U, LDU, Y, LDY, X, LX, TOL1, TOL2, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a set of parameters for approximating a Wiener system +C in a least-squares sense, using a neural network approach and a +C MINPACK-like Levenberg-Marquardt algorithm. The Wiener system +C consists of a linear part and a static nonlinearity, and it is +C represented as +C +C x(t+1) = A*x(t) + B*u(t) +C z(t) = C*x(t) + D*u(t), +C +C y(t) = f(z(t),wb(1:L)), +C +C where t = 1, 2, ..., NSMP, and f is a nonlinear function, +C evaluated by the SLICOT Library routine NF01AY. The parameter +C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), +C where theta corresponds to the linear part, and wb(i), i = 1 : L, +C correspond to the nonlinear part. See SLICOT Library routine +C NF01AD for further details. +C +C The sum of squares of the error functions, defined by +C +C e(t) = y(t) - Y(t), t = 1, 2, ..., NSMP, +C +C is minimized, where Y(t) is the measured output vector. The +C functions and their Jacobian matrices are evaluated by SLICOT +C Library routine NF01BF (the FCN routine in the call of MD03BD). +C +C ARGUMENTS +C +C Mode Parameters +C +C INIT CHARACTER*1 +C Specifies which parts have to be initialized, as follows: +C = 'L' : initialize the linear part only, X already +C contains an initial approximation of the +C nonlinearity; +C = 'S' : initialize the static nonlinearity only, X +C already contains an initial approximation of the +C linear part; +C = 'B' : initialize both linear and nonlinear parts; +C = 'N' : do not initialize anything, X already contains +C an initial approximation. +C If INIT = 'S' or 'B', the error functions for the +C nonlinear part, and their Jacobian matrices, are evaluated +C by SLICOT Library routine NF01BE (used as a second FCN +C routine in the MD03BD call for the initialization step, +C see METHOD). +C +C Input/Output Parameters +C +C NOBR (input) INTEGER +C If INIT = 'L' or 'B', NOBR is the number of block rows, s, +C in the input and output block Hankel matrices to be +C processed for estimating the linear part. NOBR > 0. +C (In the MOESP theory, NOBR should be larger than n, +C the estimated dimension of state vector.) +C This parameter is ignored if INIT is 'S' or 'N'. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L >= 0, and L > 0, if +C INIT = 'L' or 'B'. +C +C NSMP (input) INTEGER +C The number of input and output samples, t. NSMP >= 0, and +C NSMP >= 2*(M+L+1)*NOBR - 1, if INIT = 'L' or 'B'. +C +C N (input/output) INTEGER +C The order of the linear part. +C If INIT = 'L' or 'B', and N < 0 on entry, the order is +C assumed unknown and it will be found by the routine. +C Otherwise, the input value will be used. If INIT = 'S' +C or 'N', N must be non-negative. The values N >= NOBR, +C or N = 0, are not acceptable if INIT = 'L' or 'B'. +C +C NN (input) INTEGER +C The number of neurons which shall be used to approximate +C the nonlinear part. NN >= 0. +C +C ITMAX1 (input) INTEGER +C The maximum number of iterations for the initialization of +C the static nonlinearity. +C This parameter is ignored if INIT is 'N' or 'L'. +C Otherwise, ITMAX1 >= 0. +C +C ITMAX2 (input) INTEGER +C The maximum number of iterations. ITMAX2 >= 0. +C +C NPRINT (input) INTEGER +C This parameter enables controlled printing of iterates if +C it is positive. In this case, FCN is called with IFLAG = 0 +C at the beginning of the first iteration and every NPRINT +C iterations thereafter and immediately prior to return, +C and the current error norm is printed. Other intermediate +C results could be printed by modifying the corresponding +C FCN routine (NF01BE and/or NF01BF). If NPRINT <= 0, no +C special calls of FCN with IFLAG = 0 are made. +C +C U (input) DOUBLE PRECISION array, dimension (LDU, M) +C The leading NSMP-by-M part of this array must contain the +C set of input samples, +C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NSMP). +C +C Y (input) DOUBLE PRECISION array, dimension (LDY, L) +C The leading NSMP-by-L part of this array must contain the +C set of output samples, +C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,NSMP). +C +C X (input/output) DOUBLE PRECISION array dimension (LX) +C On entry, if INIT = 'L', the leading (NN*(L+2) + 1)*L part +C of this array must contain the initial parameters for +C the nonlinear part of the system. +C On entry, if INIT = 'S', the elements lin1 : lin2 of this +C array must contain the initial parameters for the linear +C part of the system, corresponding to the output normal +C form, computed by SLICOT Library routine TB01VD, where +C lin1 = (NN*(L+2) + 1)*L + 1; +C lin2 = (NN*(L+2) + 1)*L + N*(L+M+1) + L*M. +C On entry, if INIT = 'N', the elements 1 : lin2 of this +C array must contain the initial parameters for the +C nonlinear part followed by the initial parameters for the +C linear part of the system, as specified above. +C This array need not be set on entry if INIT = 'B'. +C On exit, the elements 1 : lin2 of this array contain the +C optimal parameters for the nonlinear part followed by the +C optimal parameters for the linear part of the system, as +C specified above. +C +C LX (input/output) INTEGER +C On entry, this parameter must contain the intended length +C of X. If N >= 0, then LX >= NX := lin2 (see parameter X). +C If N is unknown (N < 0 on entry), a large enough estimate +C of N should be used in the formula of lin2. +C On exit, if N < 0 on entry, but LX is not large enough, +C then this parameter contains the actual length of X, +C corresponding to the computed N. Otherwise, its value +C is unchanged. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If INIT = 'S' or 'B' and TOL1 >= 0, TOL1 is the tolerance +C which measures the relative error desired in the sum of +C squares, as well as the relative error desired in the +C approximate solution, for the initialization step of +C nonlinear part. Termination occurs when either both the +C actual and predicted relative reductions in the sum of +C squares, or the relative error between two consecutive +C iterates are at most TOL1. If the user sets TOL1 < 0, +C then SQRT(EPS) is used instead TOL1, where EPS is the +C machine precision (see LAPACK Library routine DLAMCH). +C This parameter is ignored if INIT is 'N' or 'L'. +C +C TOL2 DOUBLE PRECISION +C If TOL2 >= 0, TOL2 is the tolerance which measures the +C relative error desired in the sum of squares, as well as +C the relative error desired in the approximate solution, +C for the whole optimization process. Termination occurs +C when either both the actual and predicted relative +C reductions in the sum of squares, or the relative error +C between two consecutive iterates are at most TOL2. If the +C user sets TOL2 < 0, then SQRT(EPS) is used instead TOL2. +C This default value could require many iterations, +C especially if TOL1 is larger. If INIT = 'S' or 'B', it is +C advisable that TOL2 be larger than TOL1, and spend more +C time with cheaper iterations. +C +C Workspace +C +C IWORK INTEGER array, dimension (MAX( LIW1, LIW2, LIW3 )), where +C LIW1 = LIW2 = 0, if INIT = 'S' or 'N'; otherwise, +C LIW1 = M+L; +C LIW2 = MAX(M*NOBR+N,M*(N+L)); +C LIW3 = 3+MAX(NN*(L+2)+2,NX+L), if INIT = 'S' or 'B'; +C LIW3 = 3+NX+L, if INIT = 'L' or 'N'. +C On output, if INFO = 0, IWORK(1) and IWORK(2) return the +C (total) number of function and Jacobian evaluations, +C respectively (including the initialization step, if it was +C performed), and if INIT = 'L' or INIT = 'B', IWORK(3) +C specifies how many locations of DWORK contain reciprocal +C condition number estimates (see below); otherwise, +C IWORK(3) = 0. If INFO = 0, the entries 4 to 3+NX of IWORK +C define a permutation matrix P such that J*P = Q*R, where +C J is the final calculated Jacobian, Q is an orthogonal +C matrix (not stored), and R is upper triangular with +C diagonal elements of nonincreasing magnitude (possibly +C for each block column of J). Column j of P is column +C IWORK(3+j) of the identity matrix. Moreover, the entries +C 4+NX:3+NX+L of this array contain the ranks of the final +C submatrices S_k (see description of LMPARM in MD03BD). +C +C DWORK DOUBLE PRECISION array dimesion (LDWORK) +C On entry, if desired, and if INIT = 'S' or 'B', the +C entries DWORK(1:4) are set to initialize the random +C numbers generator for the nonlinear part parameters (see +C the description of the argument XINIT of SLICOT Library +C routine MD03BD); this enables to obtain reproducible +C results. The same seed is used for all outputs. +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the residual error norm (the +C sum of squares), DWORK(3) returns the number of iterations +C performed, and DWORK(4) returns the final Levenberg +C factor, for optimizing the parameters of both the linear +C part and the static nonlinearity part. If INIT = 'S' or +C INIT = 'B' and INFO = 0, then the elements DWORK(5) to +C DWORK(8) contain the corresponding four values for the +C initialization step (see METHOD). (If L > 1, DWORK(8) +C contains the maximum of the Levenberg factors for all +C outputs.) If INIT = 'L' or INIT = 'B', and INFO = 0, +C DWORK(9) to DWORK(8+IWORK(3)) contain reciprocal condition +C number estimates set by SLICOT Library routines IB01AD, +C IB01BD, and IB01CD. +C On exit, if INFO = -21, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C In the formulas below, N should be taken not larger than +C NOBR - 1, if N < 0 on entry. +C LDWORK = MAX( LW1, LW2, LW3, LW4 ), where +C LW1 = 0, if INIT = 'S' or 'N'; otherwise, +C LW1 = MAX( 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR, +C 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + +C MAX( LDW1, LDW2 ), +C (N+L)*(N+M) + N + N*N + 2 + N*(N+M+L) + +C MAX( 5*N, 2, MIN( LDW3, LDW4 ), LDW5, LDW6 ), +C where, +C LDW1 >= MAX( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, +C L*NOBR*N + +C MAX( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) +C LDW2 >= 0, if M = 0; +C LDW2 >= L*NOBR*N + M*NOBR*(N+L)*(M*(N+L)+1) + +C MAX( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; +C LDW3 = NSMP*L*(N+1) + 2*N + MAX( 2*N*N, 4*N ), +C LDW4 = N*(N+1) + 2*N + +C MAX( N*L*(N+1) + 2*N*N + L*N, 4*N ); +C LDW5 = NSMP*L + (N+L)*(N+M) + 3*N+M+L; +C LDW6 = NSMP*L + (N+L)*(N+M) + N + +C MAX(1, N*N*L + N*L + N, N*N + +C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), +C N*M)); +C LW2 = LW3 = 0, if INIT = 'L' or 'N'; otherwise, +C LW2 = NSMP*L + BSN + +C MAX( 4, NSMP + +C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), +C BSN**2 + BSN + +C MAX( NSMP + 2*NN, 5*BSN ) ) ); +C LW3 = MAX( LDW7, NSMP*L + (N+L)*(2*N+M) + 2*N ); +C LDW7 = NSMP*L + (N+L)*(N+M) + 3*N+M+L, if M > 0; +C LDW7 = NSMP*L + (N+L)*N + 2*N+L, if M = 0; +C LW4 = NSMP*L + NX + +C MAX( 4, NSMP*L + +C MAX( NSMP*L*( BSN + LTHS ) + +C MAX( NSMP*L + L1, L2 + NX ), +C NX*( BSN + LTHS ) + NX + +C MAX( NSMP*L + L1, NX + L3 ) ) ), +C L0 = MAX( N*(N+L), N+M+L ), if M > 0; +C L0 = MAX( N*(N+L), L ), if M = 0; +C L1 = NSMP*L + MAX( 2*NN, (N+L)*(N+M) + 2*N + L0); +C L2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, +C L2 = BSN + MAX(3*BSN+1,LTHS); +C L2 = MAX(L2,4*LTHS+1), if NSMP > BSN; +C L2 = MAX(L2,(NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; +C L3 = 4*NX, if L <= 1 or BSN = 0; +C L3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), +C if L > 1 and BSN > 0, +C with BSN = NN*( L + 2 ) + 1, +C LTHS = N*( L + M + 1 ) + L*M. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C < 0: the user set IFLAG = IWARN in (one of) the +C subroutine(s) FCN, i.e., NF01BE, if INIT = 'S' +C or 'B', and/or NF01BF; this value cannot be returned +C without changing the FCN routine(s); +C otherwise, IWARN has the value k*100 + j*10 + i, +C where k is defined below, i refers to the whole +C optimization process, and j refers to the +C initialization step (j = 0, if INIT = 'L' or 'N'), +C and the possible values for i and j have the +C following meaning (where TOL* denotes TOL1 or TOL2, +C and similarly for ITMAX*): +C = 1: both actual and predicted relative reductions in +C the sum of squares are at most TOL*; +C = 2: relative error between two consecutive iterates is +C at most TOL*; +C = 3: conditions for i or j = 1 and i or j = 2 both hold; +C = 4: the cosine of the angle between the vector of error +C function values and any column of the Jacobian is at +C most EPS in absolute value; +C = 5: the number of iterations has reached ITMAX* without +C satisfying any convergence condition; +C = 6: TOL* is too small: no further reduction in the sum +C of squares is possible; +C = 7: TOL* is too small: no further improvement in the +C approximate solution X is possible; +C = 8: the vector of function values e is orthogonal to the +C columns of the Jacobian to machine precision. +C The digit k is normally 0, but if INIT = 'L' or 'B', it +C can have a value in the range 1 to 6 (see IB01AD, IB01BD +C and IB01CD). In all these cases, the entries DWORK(1:4), +C DWORK(5:8) (if INIT = 'S' or 'B'), and DWORK(9:8+IWORK(3)) +C (if INIT = 'L' or 'B'), are set as described above. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C otherwise, INFO has the value k*100 + j*10 + i, +C where k is defined below, i refers to the whole +C optimization process, and j refers to the +C initialization step (j = 0, if INIT = 'L' or 'N'), +C and the possible values for i and j have the +C following meaning: +C = 1: the routine FCN returned with INFO <> 0 for +C IFLAG = 1; +C = 2: the routine FCN returned with INFO <> 0 for +C IFLAG = 2; +C = 3: the routine QRFACT returned with INFO <> 0; +C = 4: the routine LMPARM returned with INFO <> 0. +C In addition, if INIT = 'L' or 'B', i could also be +C = 5: if a Lyapunov equation could not be solved; +C = 6: if the identified linear system is unstable; +C = 7: if the QR algorithm failed on the state matrix +C of the identified linear system. +C QRFACT and LMPARM are generic names for SLICOT Library +C routines NF01BS and NF01BP, respectively, for the whole +C optimization process, and MD03BA and MD03BB, respectively, +C for the initialization step (if INIT = 'S' or 'B'). +C The digit k is normally 0, but if INIT = 'L' or 'B', it +C can have a value in the range 1 to 10 (see IB01AD/IB01BD). +C +C METHOD +C +C If INIT = 'L' or 'B', the linear part of the system is +C approximated using the combined MOESP and N4SID algorithm. If +C necessary, this algorithm can also choose the order, but it is +C advantageous if the order is already known. +C +C If INIT = 'S' or 'B', the output of the approximated linear part +C is computed and used to calculate an approximation of the static +C nonlinearity using the Levenberg-Marquardt algorithm [1,3]. +C This step is referred to as the (nonlinear) initialization step. +C +C As last step, the Levenberg-Marquardt algorithm is used again to +C optimize the parameters of the linear part and the static +C nonlinearity as a whole. Therefore, it is necessary to parametrise +C the matrices of the linear part. The output normal form [2] +C parameterisation is used. +C +C The Jacobian is computed analytically, for the nonlinear part, and +C numerically, for the linear part. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C [2] Peeters, R.L.M., Hanzon, B., and Olivi, M. +C Balanced realizations of discrete-time stable all-pass +C systems and the tangential Schur algorithm. +C Proceedings of the European Control Conference, +C 31 August - 3 September 1999, Karlsruhe, Germany. +C Session CP-6, Discrete-time Systems, 1999. +C +C [3] More, J.J. +C The Levenberg-Marquardt algorithm: implementation and theory. +C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in +C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg +C and New York, pp. 105-116, 1978. +C +C NUMERICAL ASPECTS +C +C The Levenberg-Marquardt algorithm described in [3] is scaling +C invariant and globally convergent to (maybe local) minima. +C The convergence rate near a local minimum is quadratic, if the +C Jacobian is computed analytically, and linear, if the Jacobian +C is computed numerically. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, March, 2002, Apr. 2002, Feb. 2004, March 2005. +C +C KEYWORDS +C +C Least-squares approximation, Levenberg-Marquardt algorithm, +C matrix operations, optimization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C FACTOR is a scaling factor for variables (see MD03BD). + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 100.0D0 ) +C Condition estimation and internal scaling of variables are used +C (see MD03BD). + CHARACTER COND, SCALE + PARAMETER ( COND = 'E', SCALE = 'I' ) +C Default tolerances are used in MD03BD for measuring the +C orthogonality between the vector of function values and columns +C of the Jacobian (GTOL), and for the rank estimations (TOL). + DOUBLE PRECISION GTOL, TOL + PARAMETER ( GTOL = 0.0D0, TOL = 0.0D0 ) +C For INIT = 'L' or 'B', additional parameters are set: +C The following six parameters are used in the call of IB01AD; + CHARACTER ALG, BATCH, CONCT, CTRL, JOBD, METH + PARAMETER ( ALG = 'Fast QR', BATCH = 'One batch', + $ CONCT = 'Not connect', CTRL = 'Not confirm', + $ JOBD = 'Not MOESP', METH = 'MOESP' ) +C The following three parameters are used in the call of IB01BD; + CHARACTER JOB, JOBCK, METHB + PARAMETER ( JOB = 'All matrices', + $ JOBCK = 'No Kalman gain', + $ METHB = 'Combined MOESP+N4SID' ) +C The following two parameters are used in the call of IB01CD; + CHARACTER COMUSE, JOBXD + PARAMETER ( COMUSE = 'Use B, D', + $ JOBXD = 'D also' ) +C TOLN controls the estimated order in IB01AD (default value); + DOUBLE PRECISION TOLN + PARAMETER ( TOLN = -1.0D0 ) +C RCOND controls the rank decisions in IB01AD, IB01BD, and IB01CD +C (default); + DOUBLE PRECISION RCOND + PARAMETER ( RCOND = -1.0D0 ) +C .. Scalar Arguments .. + CHARACTER INIT + INTEGER INFO, ITMAX1, ITMAX2, IWARN, L, LDU, LDWORK, + $ LDY, LX, M, N, NN, NOBR, NPRINT, NSMP + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), U(LDU, *), X(*), Y(LDY, *) + INTEGER IWORK(*) +C .. Local Scalars .. + INTEGER AC, BD, BSN, I, IA, IB, IDIAG, IK, INFOL, IQ, + $ IR, IRCND, IRCNDB, IRY, IS, ISAD, ISV, IV, IW1, + $ IW2, IW3, IWARNL, IX, IX0, J, JWORK, LDAC, LDR, + $ LIPAR, LNOL, LTHS, ML, MNO, N2, NFEV, NJEV, NS, + $ NSML, NTHS, NX, WRKOPT, Z + LOGICAL INIT1, INIT2 +C .. Local Arrays .. + LOGICAL BWORK(1) + INTEGER IPAR(7) + DOUBLE PRECISION RCND(16), SEED(4), WORK(4) +C .. External Functions .. + EXTERNAL LSAME + LOGICAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, IB01AD, IB01BD, IB01CD, MD03BA, MD03BB, + $ MD03BD, NF01BE, NF01BF, NF01BP, NF01BS, TB01VD, + $ TB01VY, TF01MX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INIT1 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'L' ) + INIT2 = LSAME( INIT, 'B' ) .OR. LSAME( INIT, 'S' ) +C + ML = M + L + INFO = 0 + IWARN = 0 + IF ( .NOT.( INIT1 .OR. INIT2 .OR. LSAME( INIT, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( INIT1 .AND. NOBR.LE.0 ) THEN + INFO = -2 + ELSEIF ( M.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.LT.0 .OR. ( INIT1 .AND. L.EQ.0 ) ) THEN + INFO = -4 + ELSEIF ( NSMP.LT.0 .OR. + $ ( INIT1 .AND. NSMP.LT.2*( ML + 1 )*NOBR - 1 ) ) THEN + INFO = -5 + ELSEIF ( ( N.LT.0 .AND. .NOT.INIT1 ) .OR. + $ ( ( N.EQ.0 .OR. N.GE.NOBR ) .AND. INIT1 ) ) THEN + INFO = -6 + ELSEIF ( NN.LT.0 ) THEN + INFO = -7 + ELSEIF ( INIT2 .AND. ( ITMAX1.LT.0 ) ) THEN + INFO = -8 + ELSEIF ( ITMAX2.LT.0 ) THEN + INFO = -9 + ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN + INFO = -12 + ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -14 + ELSE + LNOL = L*NOBR - L + MNO = M*NOBR + BSN = NN*( L + 2 ) + 1 + NTHS = BSN*L + NSML = NSMP*L + IF ( N.GT.0 ) THEN + LDAC = N + L + ISAD = LDAC*( N + M ) + N2 = N*N + END IF +C +C Check the workspace size. +C + JWORK = 0 + IF ( INIT1 ) THEN +C Workspace for IB01AD. + JWORK = 2*ML*NOBR*( 2*ML*( NOBR + 1 ) + 3 ) + L*NOBR + IF ( N.GT.0 ) THEN +C Workspace for IB01BD. + IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, + $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + + $ 1, MNO + 3*N + L ) ) + IF ( M.GT.0 ) THEN + IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + + $ MAX( LDAC**2, 4*M*LDAC + 1 ) + ELSE + IW2 = 0 + END IF + JWORK = MAX( JWORK, + $ ( 2*ML*NOBR )**2 + ISAD + MAX( IW1, IW2 ) ) +C Workspace for IB01CD. + IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) + IW2 = N*( N + 1 ) + 2*N + + $ MAX( N*L*( N + 1 ) + 2*N2 + L*N, 4*N ) + JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) +C Workspace for TF01MX. + JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) +C Workspace for TB01VD. + JWORK = MAX( JWORK, NSML + ISAD + N + + $ MAX( 1, N2*L + N*L + N, + $ N2 + MAX( N2 + N*MAX( N, L ) + + $ 6*N + MIN( N, L ), N*M ) ) ) + END IF + END IF +C + IF ( INIT2 ) THEN +C Workspace for MD03BD (initialization of the nonlinear part). + JWORK = MAX( JWORK, NSML + BSN + + $ MAX( 4, NSMP + + $ MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), + $ BSN**2 + BSN + + $ MAX( NSMP + 2*NN, 5*BSN ) ) ) ) + IF ( N.GT.0 .AND. .NOT.INIT1 ) THEN +C Workspace for TB01VY. + JWORK = MAX( JWORK, NSML + LDAC*( 2*N + M ) + 2*N ) +C Workspace for TF01MX. + IF ( M.GT.0 ) THEN + IW1 = N + M + ELSE + IW1 = 0 + END IF + JWORK = MAX( JWORK, NSML + ISAD + IW1 + LDAC + N ) + END IF + END IF +C + IF ( N.GE.0 ) THEN +C +C Find the number of parameters. +C + LTHS = N*( ML + 1 ) + L*M + NX = NTHS + LTHS +C + IF ( LX.LT.NX ) THEN + INFO = -16 + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF +C +C Workspace for MD03BD (whole optimization). +C + IF ( M.GT.0 ) THEN + IW1 = LDAC + M + ELSE + IW1 = L + END IF + IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) + IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN + IW3 = 4*NX + IW2 = IW3 + 1 + ELSE + IW2 = BSN + MAX( 3*BSN + 1, LTHS ) + IF ( NSMP.GT.BSN ) THEN + IW2 = MAX( IW2, 4*LTHS + 1 ) + IF ( NSMP.LT.2*BSN ) + $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) + END IF + IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) + END IF + JWORK = MAX( JWORK, NSML + NX + + $ MAX( 4, NSML + + $ MAX( NSML*( BSN + LTHS ) + + $ MAX( NSML + IW1, IW2 + NX ), + $ NX*( BSN + LTHS ) + NX + + $ MAX( NSML + IW1, NX + IW3 ) ) + $ ) ) + END IF +C + IF ( LDWORK.LT.JWORK ) THEN + INFO = -21 + DWORK(1) = JWORK + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF +C +C Initialize the pointers to system matrices and save the possible +C seed for random numbers generation. +C + Z = 1 + AC = Z + NSML + CALL DCOPY( 4, DWORK, 1, SEED, 1 ) +C + WRKOPT = 1 +C + IF ( INIT1 ) THEN +C +C Initialize the linear part. +C If N < 0, the order of the system is determined by IB01AD; +C otherwise, the given order will be used. +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: need: 2*(M+L)*NOBR*(2*(M+L)*(NOBR+1)+3) + L*NOBR; +C prefer: larger. +C Integer workspace: M+L. (If METH = 'N', (M+L)*NOBR.) +C + NS = N + IR = 1 + ISV = 2*ML*NOBR + LDR = ISV + IF ( LSAME( JOBD, 'M' ) ) + $ LDR = MAX( LDR, 3*MNO ) + ISV = IR + LDR*ISV + JWORK = ISV + L*NOBR +C + CALL IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M, L, + $ NSMP, U, LDU, Y, LDY, N, DWORK(IR), LDR, + $ DWORK(ISV), RCOND, TOLN, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARNL, INFOL ) +C + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCND = 0 + IF ( LSAME( METH, 'N' ) ) THEN + IRCND = 2 + CALL DCOPY( IRCND, DWORK(JWORK+1), 1, RCND, 1 ) + END IF +C + IF ( NS.GE.0 ) THEN + N = NS + ELSE +C +C Find the number of parameters. +C + LDAC = N + L + ISAD = LDAC*( N + M ) + N2 = N*N + LTHS = N*( ML + 1 ) + L*M + NX = NTHS + LTHS +C + IF ( LX.LT.NX ) THEN + LX = NX + INFO = -16 + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF +C Workspace for IB01BD. + IW1 = MAX( 2*LNOL*N + 2*N, LNOL*N + N2 + 7*N, L*NOBR*N + + $ MAX( LNOL*N + 2*N + ( M + ML )*NOBR + L, + $ 2*LNOL*N + N2 + 8*N, N + 4*( MNO + N ) + 1, + $ MNO + 3*N + L ) ) + IF ( M.GT.0 ) THEN + IW2 = L*NOBR*N + MNO*LDAC*( M*LDAC + 1 ) + + $ MAX( LDAC**2, 4*M*LDAC + 1 ) + ELSE + IW2 = 0 + END IF + JWORK = ISV + ISAD + MAX( IW1, IW2 ) +C Workspace for IB01CD. + IW1 = NSML*( N + 1 ) + 2*N + MAX( 2*N2, 4*N ) + IW2 = N*( N + 1 ) + 2*N + MAX( N*L*( N + 1 ) + 2*N2 + L*N, + $ 4*N ) + JWORK = MAX( JWORK, ISAD + 2 + N*( N + 1 + LDAC + M ) + + $ MAX( 5*N, 2, MIN( IW1, IW2 ) ) ) +C Workspace for TF01MX. + JWORK = MAX( JWORK, NSML + ISAD + LDAC + 2*N + M ) +C Workspace for TB01VD. + JWORK = MAX( JWORK, NSML + ISAD + N + + $ MAX( 1, N2*L + N*L + N, + $ N2 + MAX( N2 + N*MAX( N, L ) + + $ 6*N + MIN( N, L ), N*M ) ) ) +C Workspace for MD03BD (whole optimization). + IF ( M.GT.0 ) THEN + IW1 = LDAC + M + ELSE + IW1 = L + END IF + IW1 = NSML + MAX( 2*NN, ISAD + 2*N + MAX( N*LDAC, IW1 ) ) + IF ( L.LE.1 .OR. BSN.EQ.0 ) THEN + IW3 = 4*NX + IW2 = IW3 + 1 + ELSE + IW2 = BSN + MAX( 3*BSN + 1, LTHS ) + IF ( NSMP.GT.BSN ) THEN + IW2 = MAX( IW2, 4*LTHS + 1 ) + IF ( NSMP.LT.2*BSN ) + $ IW2 = MAX( IW2, ( NSMP - BSN )*( L - 1 ) ) + END IF + IW3 = LTHS*BSN + 2*NX + 2*MAX( BSN, LTHS ) + END IF + JWORK = MAX( JWORK, NSML + NX + + $ MAX( 4, NSML + + $ MAX( NSML*( BSN + LTHS ) + + $ MAX( NSML + IW1, IW2 + NX ), + $ NX*( BSN + LTHS ) + NX + + $ MAX( NSML + IW1, NX + IW3 ) ) + $ ) ) + IF ( LDWORK.LT.JWORK ) THEN + INFO = -21 + DWORK(1) = JWORK + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF + END IF +C + BD = AC + LDAC*N + IX = BD + LDAC*M + IA = ISV + IB = IA + LDAC*N + IQ = IB + LDAC*M + IF ( LSAME( JOBCK, 'N' ) ) THEN + IRY = IQ + IS = IQ + IK = IQ + JWORK = IQ + ELSE + IRY = IQ + N2 + IS = IRY + L*L + IK = IS + N*L + JWORK = IK + N*L + END IF +C +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: +C need: 4*(M+L)*NOBR*(M+L)*NOBR + (N+L)*(N+M) + +C max( LDW1,LDW2 ), where, +C LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N, +C L*NOBR*N + +C max( (L*NOBR-L)*N+2*N + (2*M+L)*NOBR+L, +C 2*(L*NOBR-L)*N+N*N+8*N, +C N+4*(M*NOBR+N)+1, M*NOBR+3*N+L ) ) +C LDW2 >= 0, if M = 0; +C LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+ +C max( (N+L)**2, 4*M*(N+L)+1 ), if M > 0; +C prefer: larger. +C Integer workspace: MAX(M*NOBR+N,M*(N+L)). +C + CALL IB01BD( METHB, JOB, JOBCK, NOBR, N, M, L, NSMP, DWORK(IR), + $ LDR, DWORK(IA), LDAC, DWORK(IA+N), LDAC, + $ DWORK(IB), LDAC, DWORK(IB+N), LDAC, DWORK(IQ), N, + $ DWORK(IRY), L, DWORK(IS), N, DWORK(IK), N, RCOND, + $ IWORK, DWORK(JWORK), LDWORK-JWORK+1, BWORK, + $ IWARNL, INFOL ) +C + IF( INFOL.EQ.-30 ) THEN + INFO = -21 + DWORK(1) = DWORK(JWORK) + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCNDB = 4 + IF ( LSAME( JOBCK, 'K' ) ) + $ IRCNDB = IRCNDB + 8 + CALL DCOPY( IRCNDB, DWORK(JWORK+1), 1, RCND(IRCND+1), 1 ) + IRCND = IRCND + IRCNDB +C +C Copy the system matrices to the beginning of DWORK, to save +C space, and redefine the pointers. +C + CALL DCOPY( ISAD, DWORK(IA), 1, DWORK, 1 ) + IA = 1 + IB = IA + LDAC*N + IX0 = IB + LDAC*M + IV = IX0 + N +C +C Compute the initial condition of the system. On normal exit, +C DWORK(i), i = JWORK+2:JWORK+1+N*N, +C DWORK(j), j = JWORK+2+N*N:JWORK+1+N*N+L*N, and +C DWORK(k), k = JWORK+2+N*N+L*N:JWORK+1+N*N+L*N+N*M, +C contain the transformed system matrices At, Ct, and Bt, +C respectively, corresponding to the real Schur form of the +C estimated system state matrix A. The transformation matrix is +C stored in DWORK(IV:IV+N*N-1). +C The workspace needed is defined for the options set above +C in the PARAMETER statements. +C Workspace: +C need: (N+L)*(N+M) + N + N*N + 2 + N*( N + M + L ) + +C max( 5*N, 2, min( LDW1, LDW2 ) ), where, +C LDW1 = NSMP*L*(N + 1) + 2*N + max( 2*N*N, 4*N), +C LDW2 = N*(N + 1) + 2*N + +C max( N*L*(N + 1) + 2*N*N + L*N, 4*N); +C prefer: larger. +C Integer workspace: N. +C + JWORK = IV + N2 + CALL IB01CD( 'X needed', COMUSE, JOBXD, N, M, L, NSMP, + $ DWORK(IA), LDAC, DWORK(IB), LDAC, DWORK(IA+N), + $ LDAC, DWORK(IB+N), LDAC, U, LDU, Y, LDY, + $ DWORK(IX0), DWORK(IV), N, RCOND, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFOL ) +C + IF( INFOL.EQ.-26 ) THEN + INFO = -21 + DWORK(1) = DWORK(JWORK) + CALL XERBLA( 'IB03BD', -INFO ) + RETURN + END IF + IF( INFOL.EQ.1 ) + $ INFOL = 10 + IF( INFOL.NE.0 ) THEN + INFO = 100*INFOL + RETURN + END IF + IF( IWARNL.NE.0 ) + $ IWARN = 100*IWARNL + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IRCND = IRCND + 1 + RCND(IRCND) = DWORK(JWORK+1) +C +C Now, save the system matrices and x0 in the final location. +C + IF ( IV.LT.AC ) THEN + CALL DCOPY( ISAD+N, DWORK(IA), 1, DWORK(AC), 1 ) + ELSE + DO 10 J = AC + ISAD + N - 1, AC, -1 + DWORK(J) = DWORK(IA+J-AC) + 10 CONTINUE + END IF +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + JWORK = IX + N + CALL DCOPY( N, DWORK(IX), 1, X(NTHS+1), 1 ) + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, X(NTHS+1), + $ DWORK(Z), NSMP, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) +C +C Convert the state-space representation to output normal form. +C Workspace: +C need: NSMP*L + (N + L)*(N + M) + N + +C MAX(1, N*N*L + N*L + N, N*N + +C MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), N*M)); +C prefer: larger. +C + CALL TB01VD( 'Apply', N, M, L, DWORK(AC), LDAC, DWORK(BD), + $ LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), LDAC, + $ DWORK(IX), X(NTHS+1), LTHS, DWORK(JWORK), + $ LDWORK-JWORK+1, INFOL ) +C + IF( INFOL.GT.0 ) THEN + INFO = INFOL + 4 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + END IF +C + LIPAR = 7 + IW1 = 0 + IW2 = 0 + IDIAG = AC +C + IF ( INIT2 ) THEN +C +C Initialize the nonlinear part. +C + IF ( .NOT.INIT1 ) THEN + BD = AC + LDAC*N + IX = BD + LDAC*M +C +C Convert the output normal form to state-space model. +C Workspace: need NSMP*L + (N + L)*(2*N + M) + 2*N. +C (NSMP*L locations are reserved for the output of the linear +C part.) +C + JWORK = IX + N + CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), + $ LDAC, DWORK(BD), LDAC, DWORK(AC+N), LDAC, + $ DWORK(BD+N), LDAC, DWORK(IX), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, + $ DWORK(IX), DWORK(Z), NSMP, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + END IF +C +C Optimize the parameters of the nonlinear part. +C Workspace: +C need NSMP*L + BSN + +C MAX( 4, NSMP + +C MAX( NSMP*BSN + MAX( 2*NN, 5*BSN + 1 ), +C BSN**2 + BSN + MAX( NSMP + 2*NN, 5*BSN ) )); +C prefer larger. +C Integer workspace: NN*(L + 2) + 2. +C + WORK(1) = ZERO + CALL DCOPY( 3, WORK(1), 0, WORK(2), 1 ) +C +C Set the integer parameters needed, including the number of +C neurons. +C + IPAR(1) = NSMP + IPAR(2) = L + IPAR(3) = NN + JWORK = IDIAG + BSN +C + DO 30 I = 0, L - 1 + CALL DCOPY( 4, SEED, 1, DWORK(JWORK), 1 ) + CALL MD03BD( 'Random initialization', SCALE, COND, NF01BE, + $ MD03BA, MD03BB, NSMP, BSN, ITMAX1, FACTOR, + $ NPRINT, IPAR, LIPAR, DWORK(Z), NSMP, Y(1,I+1), + $ LDY, X(I*BSN+1), DWORK(IDIAG), NFEV, NJEV, + $ TOL1, TOL1, GTOL, TOL, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARNL, INFOL ) + IF( INFOL.NE.0 ) THEN + INFO = 10*INFOL + RETURN + END IF + IF ( IWARNL.LT.0 ) THEN + INFO = INFOL + IWARN = IWARNL + GO TO 50 + ELSEIF ( IWARNL.GT.0 ) THEN + IF ( IWARN.GT.100 ) THEN + IWARN = MAX( IWARN, ( IWARN/100 )*100 + 10*IWARNL ) + ELSE + IWARN = MAX( IWARN, 10*IWARNL ) + END IF + END IF + WORK(1) = MAX( WORK(1), DWORK(JWORK) ) + WORK(2) = MAX( WORK(2), DWORK(JWORK+1) ) + WORK(4) = MAX( WORK(4), DWORK(JWORK+3) ) + WORK(3) = WORK(3) + DWORK(JWORK+2) + IW1 = NFEV + IW1 + IW2 = NJEV + IW2 + 30 CONTINUE +C + END IF +C +C Main iteration. +C Workspace: +C need NSMP*L + NX + +C MAX( 4, NSMP*L + +C MAX( NSMP*L*( BSN + LTHS ) + +C MAX( NSMP*L + LDW1, LDW2 + NX ), +C NX*( BSN + LTHS ) + NX + +C MAX( NSMP*L + LDW1, NX + LDW3 ) ) ), +C LDW0 = MAX( N*(N+L), N+M+L ), if M > 0; +C LDW0 = MAX( N*(N+L), L ), if M = 0; +C LDW1 = NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + LDW0); +C LDW2 = 4*NX + 1, if L <= 1 or BSN = 0; otherwise, +C LDW2 = BSN + MAX(3*BSN+1,LTHS); +C LDW2 = MAX(LDW2, 4*LTHS+1), if NSMP > BSN; +C LDW2 = MAX(LDW2, (NSMP-BSN)*(L-1)), if BSN < NSMP < 2*BSN; +C LDW3 = 4*NX, if L <= 1 or BSN = 0; +C LDW3 = LTHS*BSN + 2*NX + 2*MAX(BSN,LTHS), +C if L > 1 and BSN > 0; +C prefer larger. +C Integer workspace: NX+L. +C +C Set the integer parameters describing the Jacobian structure +C and the number of neurons. +C + IPAR(1) = LTHS + IPAR(2) = L + IPAR(3) = NSMP + IPAR(4) = BSN + IPAR(5) = M + IPAR(6) = N + IPAR(7) = NN + JWORK = IDIAG + NX +C + CALL MD03BD( 'Given initialization', SCALE, COND, NF01BF, + $ NF01BS, NF01BP, NSML, NX, ITMAX2, FACTOR, NPRINT, + $ IPAR, LIPAR, U, LDU, Y, LDY, X, DWORK(IDIAG), NFEV, + $ NJEV, TOL2, TOL2, GTOL, TOL, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARNL, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + DO 40 I = 1, NX + L + IWORK(I+3) = IWORK(I) + 40 CONTINUE +C + 50 CONTINUE + IWORK(1) = IW1 + NFEV + IWORK(2) = IW2 + NJEV + IF ( IWARNL.LT.0 ) THEN + IWARN = IWARNL + ELSE + IWARN = IWARN + IWARNL + END IF + CALL DCOPY( 4, DWORK(JWORK), 1, DWORK, 1 ) + IF ( INIT2 ) + $ CALL DCOPY( 4, WORK, 1, DWORK(5), 1 ) + IF ( INIT1 ) THEN + IWORK(3) = IRCND + CALL DCOPY( IRCND, RCND, 1, DWORK(9), 1 ) + ELSE + IWORK(3) = 0 + END IF +C + RETURN +C +C *** Last line of IB03BD *** + END diff --git a/mex/sources/libslicot/MA01AD.f b/mex/sources/libslicot/MA01AD.f new file mode 100644 index 000000000..eab214d03 --- /dev/null +++ b/mex/sources/libslicot/MA01AD.f @@ -0,0 +1,95 @@ + SUBROUTINE MA01AD( XR, XI, YR, YI ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the complex square root YR + i*YI of a complex number +C XR + i*XI in real arithmetic. The returned result is so that +C YR >= 0.0 and SIGN(YI) = SIGN(XI). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C XR (input) DOUBLE PRECISION +C XI (input) DOUBLE PRECISION +C These scalars define the real and imaginary part of the +C complex number of which the square root is sought. +C +C YR (output) DOUBLE PRECISION +C YI (output) DOUBLE PRECISION +C These scalars define the real and imaginary part of the +C complex square root. +C +C METHOD +C +C The complex square root YR + i*YI of the complex number XR + i*XI +C is computed in real arithmetic, taking care to avoid overflow. +C +C REFERENCES +C +C Adapted from EISPACK subroutine CSROOT. +C +C CONTRIBUTOR +C +C P. Benner, Universitaet Bremen, Germany, and +C R. Byers, University of Kansas, Lawrence, USA, +C Aug. 1998, routine DCROOT. +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998, SLICOT Library version. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF + PARAMETER ( ZERO = 0.0D0, HALF = 1.0D0/2.0D0 ) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION XR, XI, YR, YI +C .. +C .. Local Scalars .. + DOUBLE PRECISION S +C .. +C .. External Functions .. + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2 +C +C .. Intrinsic functions .. + INTRINSIC ABS, SQRT +C .. +C .. Executable Statements .. +C + S = SQRT( HALF*( DLAPY2( XR, XI ) + ABS( XR ) ) ) + IF ( XR.GE.ZERO ) YR = S + IF ( XI.LT.ZERO ) S = -S + IF ( XR.LE.ZERO ) THEN + YI = S + IF ( XR.LT.ZERO ) YR = HALF*( XI/S ) + ELSE + YI = HALF*( XI/YR ) + END IF +C + RETURN +C *** Last line of MA01AD *** + END diff --git a/mex/sources/libslicot/MA02AD.f b/mex/sources/libslicot/MA02AD.f new file mode 100644 index 000000000..a3cec4e40 --- /dev/null +++ b/mex/sources/libslicot/MA02AD.f @@ -0,0 +1,108 @@ + SUBROUTINE MA02AD( JOB, M, N, A, LDA, B, LDB ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/MA02BD.f b/mex/sources/libslicot/MA02BD.f new file mode 100644 index 000000000..38e713734 --- /dev/null +++ b/mex/sources/libslicot/MA02BD.f @@ -0,0 +1,113 @@ + SUBROUTINE MA02BD( SIDE, M, N, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reverse the order of rows and/or columns of a given matrix A +C by pre-multiplying and/or post-multiplying it, respectively, with +C a permutation matrix P, where P is a square matrix of appropriate +C order, with ones down the secondary diagonal. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies the operation to be performed, as follows: +C = 'L': the order of rows of A is to be reversed by +C pre-multiplying A with P; +C = 'R': the order of columns of A is to be reversed by +C post-multiplying A with P; +C = 'B': both the order of rows and the order of columns +C of A is to be reversed by pre-multiplying and +C post-multiplying A with P. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the given matrix whose rows and/or columns are to +C be permuted. +C On exit, the leading M-by-N part of this array contains +C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or +C P*A*P if SIDE = 'B'. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine PAP. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDA, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + LOGICAL BSIDES + INTEGER I, J, K, M2, N2 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DSWAP +C .. Executable Statements .. +C + BSIDES = LSAME( SIDE, 'B' ) +C + IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN +C +C Compute P*A. +C + M2 = M/2 + K = M - M2 + 1 + DO 10 J = 1, N + CALL DSWAP( M2, A(1,J), -1, A(K,J), 1 ) + 10 CONTINUE + END IF + IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN +C +C Compute A*P. +C + N2 = N/2 + K = N - N2 + 1 + DO 20 I = 1, M + CALL DSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) + 20 CONTINUE + END IF +C + RETURN +C *** Last line of MA02BD *** + END diff --git a/mex/sources/libslicot/MA02BZ.f b/mex/sources/libslicot/MA02BZ.f new file mode 100644 index 000000000..b2a699bf1 --- /dev/null +++ b/mex/sources/libslicot/MA02BZ.f @@ -0,0 +1,114 @@ + SUBROUTINE MA02BZ( SIDE, M, N, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reverse the order of rows and/or columns of a given matrix A +C by pre-multiplying and/or post-multiplying it, respectively, with +C a permutation matrix P, where P is a square matrix of appropriate +C order, with ones down the secondary diagonal. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies the operation to be performed, as follows: +C = 'L': the order of rows of A is to be reversed by +C pre-multiplying A with P; +C = 'R': the order of columns of A is to be reversed by +C post-multiplying A with P; +C = 'B': both the order of rows and the order of columns +C of A is to be reversed by pre-multiplying and +C post-multiplying A with P. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the given matrix whose rows and/or columns are to +C be permuted. +C On exit, the leading M-by-N part of this array contains +C the matrix P*A if SIDE = 'L', or A*P if SIDE = 'R', or +C P*A*P if SIDE = 'B'. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDA, M, N +C .. Array Arguments .. + COMPLEX*16 A(LDA,*) +C .. Local Scalars .. + LOGICAL BSIDES + INTEGER I, J, K, M2, N2 +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL ZSWAP +C .. Executable Statements .. +C + BSIDES = LSAME( SIDE, 'B' ) +C + IF( ( LSAME( SIDE, 'L' ) .OR. BSIDES ) .AND. M.GT.1 ) THEN +C +C Compute P*A. +C + M2 = M/2 + K = M - M2 + 1 + DO 10 J = 1, N + CALL ZSWAP( M2, A(1,J), -1, A(K,J), 1 ) + 10 CONTINUE + END IF + IF( ( LSAME( SIDE, 'R' ) .OR. BSIDES ) .AND. N.GT.1 ) THEN +C +C Compute A*P. +C + N2 = N/2 + K = N - N2 + 1 + DO 20 I = 1, M + CALL ZSWAP( N2, A(I,1), -LDA, A(I,K), LDA ) + 20 CONTINUE + END IF +C + RETURN +C *** Last line of MA02BZ *** + END diff --git a/mex/sources/libslicot/MA02CD.f b/mex/sources/libslicot/MA02CD.f new file mode 100644 index 000000000..e4948b891 --- /dev/null +++ b/mex/sources/libslicot/MA02CD.f @@ -0,0 +1,113 @@ + SUBROUTINE MA02CD( N, KL, KU, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the pertranspose of a central band of a square matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the square matrix A. N >= 0. +C +C KL (input) INTEGER +C The number of subdiagonals of A to be pertransposed. +C 0 <= KL <= N-1. +C +C KU (input) INTEGER +C The number of superdiagonals of A to be pertransposed. +C 0 <= KU <= N-1. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain a square matrix whose central band formed from +C the KL subdiagonals, the main diagonal and the KU +C superdiagonals will be pertransposed. +C On exit, the leading N-by-N part of this array contains +C the matrix A with its central band (the KL subdiagonals, +C the main diagonal and the KU superdiagonals) pertransposed +C (that is the elements of each antidiagonal appear in +C reversed order). This is equivalent to forming P*B'*P, +C where B is the matrix formed from the central band of A +C and P is a permutation matrix with ones down the secondary +C diagonal. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine DMPTR. +C +C REVISIONS +C +C A. Varga, December 2001. +C V. Sima, March 2004. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER KL, KU, LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER I, I1, LDA1 +C .. External Subroutines .. + EXTERNAL DSWAP +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C Quick return if possible. +C + IF( N.LE.1 ) + $ RETURN +C + LDA1 = LDA + 1 +C +C Pertranspose the KL subdiagonals. +C + DO 10 I = 1, MIN( KL, N-2 ) + I1 = (N-I) / 2 + IF( I1.GT.0 ) + $ CALL DSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) + 10 CONTINUE +C +C Pertranspose the KU superdiagonals. +C + DO 20 I = 1, MIN( KU, N-2 ) + I1 = (N-I) / 2 + IF( I1.GT.0 ) + $ CALL DSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) + 20 CONTINUE +C +C Pertranspose the diagonal. +C + I1 = N / 2 + IF( I1.GT.0 ) + $ CALL DSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) +C + RETURN +C *** Last line of MA02CD *** + END diff --git a/mex/sources/libslicot/MA02CZ.f b/mex/sources/libslicot/MA02CZ.f new file mode 100644 index 000000000..5bb85b5ed --- /dev/null +++ b/mex/sources/libslicot/MA02CZ.f @@ -0,0 +1,113 @@ + SUBROUTINE MA02CZ( N, KL, KU, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the pertranspose of a central band of a square matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the square matrix A. N >= 0. +C +C KL (input) INTEGER +C The number of subdiagonals of A to be pertransposed. +C 0 <= KL <= N-1. +C +C KU (input) INTEGER +C The number of superdiagonals of A to be pertransposed. +C 0 <= KU <= N-1. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain a square matrix whose central band formed from +C the KL subdiagonals, the main diagonal and the KU +C superdiagonals will be pertransposed. +C On exit, the leading N-by-N part of this array contains +C the matrix A with its central band (the KL subdiagonals, +C the main diagonal and the KU superdiagonals) pertransposed +C (that is the elements of each antidiagonal appear in +C reversed order). This is equivalent to forming P*B'*P, +C where B is the matrix formed from the central band of A +C and P is a permutation matrix with ones down the secondary +C diagonal. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER KL, KU, LDA, N +C .. Array Arguments .. + COMPLEX*16 A(LDA,*) +C .. Local Scalars .. + INTEGER I, I1, LDA1 +C .. External Subroutines .. + EXTERNAL ZSWAP +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C Quick return if possible. +C + IF( N.LE.1 ) + $ RETURN +C + LDA1 = LDA + 1 +C +C Pertranspose the KL subdiagonals. +C + DO 10 I = 1, MIN( KL, N-2 ) + I1 = (N-I) / 2 + IF( I1.GT.0 ) + $ CALL ZSWAP( I1, A(I+1,1), LDA1, A(N-I1+1,N-I1+1-I), -LDA1 ) + 10 CONTINUE +C +C Pertranspose the KU superdiagonals. +C + DO 20 I = 1, MIN( KU, N-2 ) + I1 = (N-I) / 2 + IF( I1.GT.0 ) + $ CALL ZSWAP( I1, A(1,I+1), LDA1, A(N-I1+1-I,N-I1+1), -LDA1 ) + 20 CONTINUE +C +C Pertranspose the diagonal. +C + I1 = N / 2 + IF( I1.GT.0 ) + $ CALL ZSWAP( I1, A(1,1), LDA1, A(N-I1+1,N-I1+1), -LDA1 ) +C + RETURN +C *** Last line of MA02CZ *** + END diff --git a/mex/sources/libslicot/MA02DD.f b/mex/sources/libslicot/MA02DD.f new file mode 100644 index 000000000..ef7967e73 --- /dev/null +++ b/mex/sources/libslicot/MA02DD.f @@ -0,0 +1,157 @@ + SUBROUTINE MA02DD( JOB, UPLO, N, A, LDA, AP ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To pack/unpack the upper or lower triangle of a symmetric matrix. +C The packed matrix is stored column-wise in the one-dimensional +C array AP. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies whether the matrix should be packed or unpacked, +C as follows: +C = 'P': The matrix should be packed; +C = 'U': The matrix should be unpacked. +C +C UPLO CHARACTER*1 +C Specifies the part of the matrix to be packed/unpacked, +C as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input or output) DOUBLE PRECISION array, dimension +C (LDA,N) +C This array is an input parameter if JOB = 'P', and an +C output parameter if JOB = 'U'. +C On entry, if JOB = 'P', the leading N-by-N upper +C triangular part (if UPLO = 'U'), or lower triangular part +C (if UPLO = 'L'), of this array must contain the +C corresponding upper or lower triangle of the symmetric +C matrix A, and the other strictly triangular part is not +C referenced. +C On exit, if JOB = 'U', the leading N-by-N upper triangular +C part (if UPLO = 'U'), or lower triangular part (if +C UPLO = 'L'), of this array contains the corresponding +C upper or lower triangle of the symmetric matrix A; the +C other strictly triangular part is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C AP (output or input) DOUBLE PRECISION array, dimension +C (N*(N+1)/2) +C This array is an output parameter if JOB = 'P', and an +C input parameter if JOB = 'U'. +C On entry, if JOB = 'U', the leading N*(N+1)/2 elements of +C this array must contain the upper (if UPLO = 'U') or lower +C (if UPLO = 'L') triangle of the symmetric matrix A, packed +C column-wise. That is, the elements are stored in the order +C 11, 12, 22, ..., 1n, 2n, 3n, ..., nn, if UPLO = 'U'; +C 11, 21, 31, ..., n1, 22, 32, ..., n2, ..., if UPLO = 'L'. +C On exit, if JOB = 'P', the leading N*(N+1)/2 elements of +C this array contain the upper (if UPLO = 'U') or lower +C (if UPLO = 'L') triangle of the symmetric matrix A, packed +C column-wise, as described above. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER JOB, UPLO + INTEGER LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), AP(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER IJ, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked for errors. +C + LUPLO = LSAME( UPLO, 'L' ) + IJ = 1 + IF( LSAME( JOB, 'P' ) ) THEN + IF( LUPLO ) THEN +C +C Pack the lower triangle of A. +C + DO 20 J = 1, N + CALL DCOPY( N-J+1, A(J,J), 1, AP(IJ), 1 ) + IJ = IJ + N - J + 1 + 20 CONTINUE +C + ELSE +C +C Pack the upper triangle of A. +C + DO 40 J = 1, N + CALL DCOPY( J, A(1,J), 1, AP(IJ), 1 ) + IJ = IJ + J + 40 CONTINUE +C + END IF + ELSE + IF( LUPLO ) THEN +C +C Unpack the lower triangle of A. +C + DO 60 J = 1, N + CALL DCOPY( N-J+1, AP(IJ), 1, A(J,J), 1 ) + IJ = IJ + N - J + 1 + 60 CONTINUE +C + ELSE +C +C Unpack the upper triangle of A. +C + DO 80 J = 1, N + CALL DCOPY( J, AP(IJ), 1, A(1,J), 1 ) + IJ = IJ + J + 80 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of MA02DD *** + END diff --git a/mex/sources/libslicot/MA02ED.f b/mex/sources/libslicot/MA02ED.f new file mode 100644 index 000000000..79ce82f7c --- /dev/null +++ b/mex/sources/libslicot/MA02ED.f @@ -0,0 +1,99 @@ + SUBROUTINE MA02ED( UPLO, N, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/MA02FD.f b/mex/sources/libslicot/MA02FD.f new file mode 100644 index 000000000..f2ec4350b --- /dev/null +++ b/mex/sources/libslicot/MA02FD.f @@ -0,0 +1,104 @@ + SUBROUTINE MA02FD( X1, X2, C, S, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients c and s (c^2 + s^2 = 1) for a modified +C hyperbolic plane rotation, such that, +C +C y1 := 1/c * x1 - s/c * x2 = sqrt(x1^2 - x2^2), +C y2 := -s * y1 + c * x2 = 0, +C +C given two real numbers x1 and x2, satisfying either x1 = x2 = 0, +C or abs(x2) < abs(x1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C X1 (input/output) DOUBLE PRECISION +C On entry, the real number x1. +C On exit, the real number y1. +C +C X2 (input) DOUBLE PRECISION +C The real number x2. +C The values x1 and x2 should satisfy either x1 = x2 = 0, or +C abs(x2) < abs(x1). +C +C C (output) DOUBLE PRECISION +C The cosines c of the modified hyperbolic plane rotation. +C +C S (output) DOUBLE PRECISION +C The sines s of the modified hyperbolic plane rotation. +C +C Error Indicator +C +C INFO INTEGER +C = 0: succesful exit; +C = 1: if abs(x2) >= abs(x1) and either x1 <> 0 or x2 <> 0. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. +C +C KEYWORDS +C +C Orthogonal transformation, plane rotation. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION X1, X2, C, S + INTEGER INFO +C .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +C .. Executable Statements .. +C + IF ( ( X1.NE.ZERO .OR. X2.NE.ZERO ) .AND. + $ ABS( X2 ).GE.ABS( X1 ) ) THEN + INFO = 1 + ELSE + INFO = 0 + IF ( X1.EQ.ZERO ) THEN + S = ZERO + C = ONE + ELSE + S = X2 / X1 +C +C No overflows could appear in the next statement; underflows +C are possible if X2 is tiny and X1 is huge, but then +C abs(C) = ONE - delta, +C where delta is much less than machine precision. +C + C = SIGN( SQRT( ONE - S ) * SQRT( ONE + S ), X1 ) + X1 = C * X1 + END IF + END IF +C + RETURN +C *** Last line of MA02FD *** + END diff --git a/mex/sources/libslicot/MA02GD.f b/mex/sources/libslicot/MA02GD.f new file mode 100644 index 000000000..90cda2ed4 --- /dev/null +++ b/mex/sources/libslicot/MA02GD.f @@ -0,0 +1,158 @@ + SUBROUTINE MA02GD( N, A, LDA, K1, K2, IPIV, INCX ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/MA02HD.f b/mex/sources/libslicot/MA02HD.f new file mode 100644 index 000000000..2017da866 --- /dev/null +++ b/mex/sources/libslicot/MA02HD.f @@ -0,0 +1,180 @@ + LOGICAL FUNCTION MA02HD( JOB, M, N, DIAG, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To check if A = DIAG*I, where I is an M-by-N matrix with ones on +C the diagonal and zeros elsewhere. +C +C FUNCTION VALUE +C +C MA02HD LOGICAL +C The function value is set to .TRUE. if A = DIAG*I, and to +C .FALSE., otherwise. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the part of the matrix A to be checked out, +C as follows: +C = 'U': Upper triangular/trapezoidal part; +C = 'L': Lower triangular/trapezoidal part. +C Otherwise: All of the matrix A. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C DIAG (input) DOUBLE PRECISION +C The scalar DIAG. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix A. If JOB = 'U', only the upper triangle or +C trapezoid is accessed; if JOB = 'L', only the lower +C triangle or trapezoid is accessed. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C METHOD +C +C The routine returns immediately after detecting a diagonal element +C which differs from DIAG, or a nonzero off-diagonal element in the +C searched part of A. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003. +C +C KEYWORDS +C +C Elementary operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER LDA, M, N + DOUBLE PRECISION DIAG +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER I, J +C .. External Functions + LOGICAL LSAME + EXTERNAL LSAME +C .. Intrinsic Functions .. + INTRINSIC MIN +C +C .. Executable Statements .. +C +C Do not check parameters, for efficiency. +C + IF( LSAME( JOB, 'U' ) ) THEN +C + DO 20 J = 1, N +C + DO 10 I = 1, MIN( J-1, M ) + IF( A(I,J).NE.ZERO ) THEN + MA02HD = .FALSE. + RETURN + END IF + 10 CONTINUE +C + IF( J.LE.M ) THEN + IF( A(J,J).NE.DIAG ) THEN + MA02HD = .FALSE. + RETURN + END IF + END IF + 20 CONTINUE +C + ELSE IF( LSAME( JOB, 'L' ) ) THEN +C + DO 40 J = 1, MIN( M, N ) + IF( A(J,J).NE.DIAG ) THEN + MA02HD = .FALSE. + RETURN + END IF +C + IF ( J.NE.M ) THEN +C + DO 30 I = MIN( J+1, M ), M + IF( A(I,J).NE.ZERO ) THEN + MA02HD = .FALSE. + RETURN + END IF + 30 CONTINUE +C + END IF + 40 CONTINUE +C + ELSE +C + DO 70 J = 1, N +C + DO 50 I = 1, MIN( J-1, M ) + IF( A(I,J).NE.ZERO ) THEN + MA02HD = .FALSE. + RETURN + END IF + 50 CONTINUE +C + IF( J.LE.M ) THEN + IF( A(J,J).NE.DIAG ) THEN + MA02HD = .FALSE. + RETURN + END IF + END IF +C + IF ( J.LT.M ) THEN +C + DO 60 I = MIN( J+1, M ), M + IF( A(I,J).NE.ZERO ) THEN + MA02HD = .FALSE. + RETURN + END IF + 60 CONTINUE +C + END IF + 70 CONTINUE +C + END IF +C + MA02HD = .TRUE. +C + RETURN +C *** Last line of MA02HD *** + END diff --git a/mex/sources/libslicot/MA02ID.f b/mex/sources/libslicot/MA02ID.f new file mode 100644 index 000000000..8b822bb55 --- /dev/null +++ b/mex/sources/libslicot/MA02ID.f @@ -0,0 +1,293 @@ + DOUBLE PRECISION FUNCTION MA02ID( TYP, NORM, N, A, LDA, QG, + $ LDQG, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the value of the one norm, or the Frobenius norm, or +C the infinity norm, or the element of largest absolute value +C of a real skew-Hamiltonian matrix +C +C [ A G ] T T +C X = [ T ], G = -G, Q = -Q, +C [ Q A ] +C +C or of a real Hamiltonian matrix +C +C [ A G ] T T +C X = [ T ], G = G, Q = Q, +C [ Q -A ] +C +C where A, G and Q are real n-by-n matrices. +C +C Note that for this kind of matrices the infinity norm is equal +C to the one norm. +C +C FUNCTION VALUE +C +C MA02ID DOUBLE PRECISION +C The computed norm. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYP CHARACTER*1 +C Specifies the type of the input matrix X: +C = 'S': X is skew-Hamiltonian; +C = 'H': X is Hamiltonian. +C +C NORM CHARACTER*1 +C Specifies the value to be returned in MA02ID: +C = '1' or 'O': one norm of X; +C = 'F' or 'E': Frobenius norm of X; +C = 'I': infinity norm of X; +C = 'M': max(abs(X(i,j)). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain in columns 1:N the lower triangular part of the +C matrix Q and in columns 2:N+1 the upper triangular part +C of the matrix G. If TYP = 'S', the parts containing the +C diagonal and the first supdiagonal of this array are not +C referenced. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C Workspace +C +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C where LDWORK >= 2*N when NORM = '1', NORM = 'I' or +C NORM = 'O'; otherwise, DWORK is not referenced. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLANHA). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix, skew-Hamiltonian +C matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER NORM, TYP + INTEGER LDA, LDQG, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*) +C .. Local Scalars .. + LOGICAL LSH + INTEGER I, J + DOUBLE PRECISION DSCL, DSUM, SCALE, SUM, TEMP, VALUE +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLANGE, DLAPY2 + EXTERNAL DLANGE, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DLASSQ +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C +C .. Executable Statements .. +C + LSH = LSAME( TYP, 'S' ) +C + IF ( N.EQ.0 ) THEN + VALUE = ZERO +C + ELSE IF ( LSAME( NORM, 'M' ) .AND. LSH ) THEN +C +C Find max(abs(A(i,j))). +C + VALUE = DLANGE( 'MaxElement', N, N, A, LDA, DWORK ) + IF ( N.GT.1 ) THEN + DO 30 J = 1, N+1 + DO 10 I = 1, J-2 + VALUE = MAX( VALUE, ABS( QG(I,J) ) ) + 10 CONTINUE + DO 20 I = J+1, N + VALUE = MAX( VALUE, ABS( QG(I,J) ) ) + 20 CONTINUE + 30 CONTINUE + END IF +C + ELSE IF ( LSAME( NORM, 'M' ) ) THEN +C +C Find max( abs( A(i,j) ), abs( QG(i,j) ) ). +C + VALUE = MAX( DLANGE( 'MaxElement', N, N, A, LDA, DWORK ), + $ DLANGE( 'MaxElement', N, N+1, QG, LDQG, + $ DWORK ) ) +C + ELSE IF ( ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. + $ LSAME( NORM, 'I' ) ) .AND. LSH ) THEN +C +C Find the column and row sums of A (in one pass). +C + VALUE = ZERO + DO 40 I = 1, N + DWORK(I) = ZERO + 40 CONTINUE +C + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, N + TEMP = ABS( A(I,J) ) + SUM = SUM + TEMP + DWORK(I) = DWORK(I) + TEMP + 50 CONTINUE + DWORK(N+J) = SUM + 60 CONTINUE +C +C Compute the maximal absolute column sum. +C + DO 90 J = 1, N+1 + DO 70 I = 1, J-2 + TEMP = ABS( QG(I,J) ) + DWORK(I) = DWORK(I) + TEMP + DWORK(J-1) = DWORK(J-1) + TEMP + 70 CONTINUE + IF ( J.LT.N+1 ) THEN + SUM = DWORK(N+J) + DO 80 I = J+1, N + TEMP = ABS( QG(I,J) ) + SUM = SUM + TEMP + DWORK(N+I) = DWORK(N+I) + TEMP + 80 CONTINUE + VALUE = MAX( VALUE, SUM ) + END IF + 90 CONTINUE + DO 100 I = 1, N + VALUE = MAX( VALUE, DWORK(I) ) + 100 CONTINUE +C + ELSE IF ( LSAME( NORM, 'O' ) .OR. ( NORM.EQ.'1' ) .OR. + $ LSAME( NORM, 'I' ) ) THEN +C +C Find the column and row sums of A (in one pass). +C + VALUE = ZERO + DO 110 I = 1, N + DWORK(I) = ZERO + 110 CONTINUE +C + DO 130 J = 1, N + SUM = ZERO + DO 120 I = 1, N + TEMP = ABS( A(I,J) ) + SUM = SUM + TEMP + DWORK(I) = DWORK(I) + TEMP + 120 CONTINUE + DWORK(N+J) = SUM + 130 CONTINUE +C +C Compute the maximal absolute column sum. +C + DO 160 J = 1, N+1 + DO 140 I = 1, J-2 + TEMP = ABS( QG(I,J) ) + DWORK(I) = DWORK(I) + TEMP + DWORK(J-1) = DWORK(J-1) + TEMP + 140 CONTINUE + IF ( J.GT.1 ) + $ DWORK(J-1) = DWORK(J-1) + ABS( QG(J-1,J) ) + IF ( J.LT.N+1 ) THEN + SUM = DWORK(N+J) + ABS( QG(J,J) ) + DO 150 I = J+1, N + TEMP = ABS( QG(I,J) ) + SUM = SUM + TEMP + DWORK(N+I) = DWORK(N+I) + TEMP + 150 CONTINUE + VALUE = MAX( VALUE, SUM ) + END IF + 160 CONTINUE + DO 170 I = 1, N + VALUE = MAX( VALUE, DWORK(I) ) + 170 CONTINUE +C + ELSE IF ( ( LSAME( NORM, 'F' ) .OR. + $ LSAME( NORM, 'E' ) ) .AND. LSH ) THEN +C +C Find normF(A). +C + SCALE = ZERO + SUM = ONE + DO 180 J = 1, N + CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) + 180 CONTINUE +C +C Add normF(G) and normF(Q). +C + DO 190 J = 1, N+1 + IF ( J.GT.2 ) + $ CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) + IF ( J.LT.N ) + $ CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) + 190 CONTINUE + VALUE = SQRT( TWO )*SCALE*SQRT( SUM ) + ELSE IF ( LSAME( NORM, 'F' ) .OR. LSAME( NORM, 'E' ) ) THEN + SCALE = ZERO + SUM = ONE + DO 200 J = 1, N + CALL DLASSQ( N, A(1,J), 1, SCALE, SUM ) + 200 CONTINUE + DSCL = ZERO + DSUM = ONE + DO 210 J = 1, N+1 + IF ( J.GT.1 ) THEN + CALL DLASSQ( J-2, QG(1,J), 1, SCALE, SUM ) + CALL DLASSQ( 1, QG(J-1,J), 1, DSCL, DSUM ) + END IF + IF ( J.LT.N+1 ) THEN + CALL DLASSQ( 1, QG(J,J), 1, DSCL, DSUM ) + CALL DLASSQ( N-J, QG(J+1,J), 1, SCALE, SUM ) + END IF + 210 CONTINUE + VALUE = DLAPY2( SQRT( TWO )*SCALE*SQRT( SUM ), + $ DSCL*SQRT( DSUM ) ) + END IF +C + MA02ID = VALUE + RETURN +C *** Last line of MA02ID *** + END diff --git a/mex/sources/libslicot/MA02JD.f b/mex/sources/libslicot/MA02JD.f new file mode 100644 index 000000000..ebf75d0a2 --- /dev/null +++ b/mex/sources/libslicot/MA02JD.f @@ -0,0 +1,164 @@ + DOUBLE PRECISION FUNCTION MA02JD( LTRAN1, LTRAN2, N, Q1, LDQ1, Q2, + $ LDQ2, RES, LDRES ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute || Q^T Q - I ||_F for a matrix of the form +C +C [ op( Q1 ) op( Q2 ) ] +C Q = [ ], +C [ -op( Q2 ) op( Q1 ) ] +C +C where Q1 and Q2 are N-by-N matrices. This residual can be used to +C test wether Q is numerically an orthogonal symplectic matrix. +C +C FUNCTION VALUE +C +C MA02JD DOUBLE PRECISION +C The computed residual. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRAN1 LOGICAL +C Specifies the form of op( Q1 ) as follows: +C = .FALSE.: op( Q1 ) = Q1; +C = .TRUE. : op( Q1 ) = Q1'. +C +C LTRAN2 LOGICAL +C Specifies the form of op( Q2 ) as follows: +C = .FALSE.: op( Q2 ) = Q2; +C = .TRUE. : op( Q2 ) = Q2'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices Q1 and Q2. N >= 0. +C +C Q1 (input) DOUBLE PRECISION array, dimension (LDQ1,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix op( Q1 ). +C +C LDQ1 INTEGER +C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). +C +C Q2 (input) DOUBLE PRECISION array, dimension (LDQ2,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix op( Q2 ). +C +C LDQ2 INTEGER +C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). +C +C Workspace +C +C RES DOUBLE PRECISION array, dimension (LDRES,N) +C +C LDRES INTEGER +C The leading dimension of the array RES. LDRES >= MAX(1,N). +C +C METHOD +C +C The routine computes the residual by simple elementary operations. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAORS). +C +C KEYWORDS +C +C Elementary operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + LOGICAL LTRAN1, LTRAN2 + INTEGER LDQ1, LDQ2, LDRES, N +C .. Array Arguments .. + DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), RES(LDRES,*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Subroutines .. + EXTERNAL DGEMM +C .. External Functions .. + DOUBLE PRECISION DLANGE, DLAPY2 + EXTERNAL DLANGE, DLAPY2 +C .. Intrinsic Functions .. + INTRINSIC SQRT +C +C .. Executable Statements .. +C + IF ( LTRAN1 ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q1, LDQ1, ZERO, RES, LDRES ) + END IF + IF ( LTRAN2 ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q2, LDQ2, ONE, RES, LDRES ) + END IF + DO 10 I = 1, N + RES(I,I) = RES(I,I) - ONE + 10 CONTINUE + TEMP = DLANGE( 'Frobenius', N, N, RES, LDRES, DUMMY ) + IF ( LTRAN1 .AND. LTRAN2 ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) + CALL DGEMM( 'No Transpose', 'Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) + ELSE IF ( LTRAN1 ) THEN + CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) + ELSE IF ( LTRAN2 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) + CALL DGEMM( 'Transpose', 'Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) + ELSE + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q2, + $ LDQ2, Q1, LDQ1, ZERO, RES, LDRES ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, Q1, + $ LDQ1, Q2, LDQ2, -ONE, RES, LDRES ) + END IF + TEMP = DLAPY2( TEMP, DLANGE( 'Frobenius', N, N, RES, LDRES, + $ DUMMY ) ) + MA02JD = SQRT( TWO )*TEMP + RETURN +C *** Last line of MA02JD *** + END diff --git a/mex/sources/libslicot/MB01MD.f b/mex/sources/libslicot/MB01MD.f new file mode 100644 index 000000000..94f99f57a --- /dev/null +++ b/mex/sources/libslicot/MB01MD.f @@ -0,0 +1,279 @@ + SUBROUTINE MB01MD( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the matrix-vector operation +C +C y := alpha*A*x + beta*y, +C +C where alpha and beta are scalars, x and y are vectors of length +C n and A is an n-by-n skew-symmetric matrix. +C +C This is a modified version of the vanilla implemented BLAS +C routine DSYMV written by Jack Dongarra, Jeremy Du Croz, +C Sven Hammarling, and Richard Hanson. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies whether the upper or lower triangular part of +C the array A is to be referenced as follows: +C = 'U': only the strictly upper triangular part of A is to +C be referenced; +C = 'L': only the strictly lower triangular part of A is to +C be referenced. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. If alpha is zero the array A is not +C referenced. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C On entry with UPLO = 'U', the leading N-by-N part of this +C array must contain the strictly upper triangular part of +C the matrix A. The lower triangular part of this array is +C not referenced. +C On entry with UPLO = 'L', the leading N-by-N part of this +C array must contain the strictly lower triangular part of +C the matrix A. The upper triangular part of this array is +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N) +C +C X (input) DOUBLE PRECISION array, dimension +C ( 1 + ( N - 1 )*abs( INCX ) ). +C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of +C this array must contain the elements of the vector X. +C +C INCX (input) INTEGER +C The increment for the elements of X. IF INCX < 0 then the +C elements of X are accessed in reversed order. INCX <> 0. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. If beta is zero then Y need not be set on +C input. +C +C Y (input/output) DOUBLE PRECISION array, dimension +C ( 1 + ( N - 1 )*abs( INCY ) ). +C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of +C this array must contain the elements of the vector Y. +C On exit, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of +C this array contain the updated elements of the vector Y. +C +C INCY (input) INTEGER +C The increment for the elements of Y. IF INCY < 0 then the +C elements of Y are accessed in reversed order. INCY <> 0. +C +C NUMERICAL ASPECTS +C +C Though being almost identical with the vanilla implementation +C of the BLAS routine DSYMV the performance of this routine could +C be significantly lower in the case of vendor supplied, highly +C optimized BLAS. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKMV). +C +C KEYWORDS +C +C Elementary matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N + CHARACTER UPLO +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), X(*), Y(*) +C .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = 1 + ELSE IF ( N.LT.0 )THEN + INFO = 2 + ELSE IF ( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF ( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF ( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF ( INFO.NE.0 )THEN + CALL XERBLA( 'MB01MD', INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +C +C Set up the start points in X and Y. +C + IF ( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF ( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +C +C Start the operations. In this version the elements of A are +C accessed sequentially with one pass through the triangular part +C of A. +C +C First form y := beta*y. +C + IF ( BETA.NE.ONE )THEN + IF ( INCY.EQ.1 )THEN + IF ( BETA.EQ.ZERO )THEN + DO 10 I = 1, N + Y(I) = ZERO + 10 CONTINUE + ELSE + DO 20 I = 1, N + Y(I) = BETA*Y(I) + 20 CONTINUE + END IF + ELSE + IY = KY + IF ( BETA.EQ.ZERO )THEN + DO 30 I = 1, N + Y(IY) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40 I = 1, N + Y(IY) = BETA*Y(IY) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF +C +C Quick return if possible. +C + IF ( ALPHA.EQ.ZERO ) + $ RETURN + IF ( LSAME( UPLO, 'U' ) )THEN +C +C Form y when A is stored in upper triangle. +C + IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60 J = 2, N + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 50, I = 1, J - 1 + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(I) + 50 CONTINUE + Y(J) = Y(J) - ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + INCX + JY = KY + INCY + DO 80 J = 2, N + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70 I = 1, J - 1 + Y(IY) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(IX) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y(JY) = Y(JY) - ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +C +C Form y when A is stored in lower triangle. +C + IF ( ( INCX.EQ.1 ) .AND. ( INCY.EQ.1 ) )THEN + DO 100 J = 1, N - 1 + TEMP1 = ALPHA*X(J) + TEMP2 = ZERO + DO 90 I = J + 1, N + Y(I) = Y(I) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(I) + 90 CONTINUE + Y(J) = Y(J) - ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120 J = 1, N - 1 + TEMP1 = ALPHA*X(JX) + TEMP2 = ZERO + IX = JX + IY = JY + DO 110 I = J + 1, N + IX = IX + INCX + IY = IY + INCY + Y(IY ) = Y(IY) + TEMP1*A(I,J) + TEMP2 = TEMP2 + A(I,J)*X(IX) + 110 CONTINUE + Y(JY) = Y(JY) - ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +C *** Last line of MB01MD *** + END diff --git a/mex/sources/libslicot/MB01ND.f b/mex/sources/libslicot/MB01ND.f new file mode 100644 index 000000000..036facf71 --- /dev/null +++ b/mex/sources/libslicot/MB01ND.f @@ -0,0 +1,249 @@ + SUBROUTINE MB01ND( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the skew-symmetric rank 2 operation +C +C A := alpha*x*y' - alpha*y*x' + A, +C +C where alpha is a scalar, x and y are vectors of length n and A is +C an n-by-n skew-symmetric matrix. +C +C This is a modified version of the vanilla implemented BLAS +C routine DSYR2 written by Jack Dongarra, Jeremy Du Croz, +C Sven Hammarling, and Richard Hanson. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies whether the upper or lower triangular part of +C the array A is to be referenced as follows: +C = 'U': only the strictly upper triangular part of A is to +C be referenced; +C = 'L': only the strictly lower triangular part of A is to +C be referenced. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. If alpha is zero X and Y are not +C referenced. +C +C X (input) DOUBLE PRECISION array, dimension +C ( 1 + ( N - 1 )*abs( INCX ) ). +C On entry, elements 1, INCX+1, .., ( N - 1 )*INCX + 1 of +C this array must contain the elements of the vector X. +C +C INCX (input) INTEGER +C The increment for the elements of X. IF INCX < 0 then the +C elements of X are accessed in reversed order. INCX <> 0. +C +C Y (input) DOUBLE PRECISION array, dimension +C ( 1 + ( N - 1 )*abs( INCY ) ). +C On entry, elements 1, INCY+1, .., ( N - 1 )*INCY + 1 of +C this array must contain the elements of the vector Y. +C +C INCY (input) INTEGER +C The increment for the elements of Y. IF INCY < 0 then the +C elements of Y are accessed in reversed order. INCY <> 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry with UPLO = 'U', the leading N-by-N part of this +C array must contain the strictly upper triangular part of +C the matrix A. The lower triangular part of this array is +C not referenced. +C On entry with UPLO = 'L', the leading N-by-N part of this +C array must contain the strictly lower triangular part of +C the matrix A. The upper triangular part of this array is +C not referenced. +C On exit with UPLO = 'U', the leading N-by-N part of this +C array contains the strictly upper triangular part of the +C updated matrix A. +C On exit with UPLO = 'L', the leading N-by-N part of this +C array contains the strictly lower triangular part of the +C updated matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N) +C +C NUMERICAL ASPECTS +C +C Though being almost identical with the vanilla implementation +C of the BLAS routine DSYR2 the performance of this routine could +C be significantly lower in the case of vendor supplied, highly +C optimized BLAS. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DSKR2). +C +C KEYWORDS +C +C Elementary matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, LDA, N + CHARACTER UPLO +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +C .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF ( N.LT.0 )THEN + INFO = 2 + ELSE IF ( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF ( INCY.EQ.0 )THEN + INFO = 7 + ELSE IF ( LDA.LT.MAX( 1, N ) )THEN + INFO = 9 + END IF +C + IF ( INFO.NE.0 )THEN + CALL XERBLA( 'MB01ND', INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +C +C Set up the start points in X and Y if the increments are not both +C unity. +C + IF ( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN + IF ( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF ( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF + JX = KX + JY = KY + END IF +C +C Start the operations. In this version the elements of A are +C accessed sequentially with one pass through the triangular part +C of A. +C + IF ( LSAME( UPLO, 'U' ) )THEN +C +C Form A when A is stored in the upper triangle. +C + IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 20 J = 2, N + IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 10 I = 1, J-1 + A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40 J = 2, N + IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = KX + IY = KY + DO 30 I = 1, J-1 + A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +C +C Form A when A is stored in the lower triangle. +C + IF ( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60 J = 1, N-1 + IF ( ( X(J).NE.ZERO ).OR.( Y(J).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y(J) + TEMP2 = ALPHA*X(J) + DO 50 I = J+1, N + A(I,J) = A(I,J) + X(I)*TEMP1 - Y(I)*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80 J = 1, N-1 + IF ( ( X(JX).NE.ZERO ).OR.( Y(JY).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y(JY) + TEMP2 = ALPHA*X(JX) + IX = JX + IY = JY + DO 70 I = J+1, N + A(I,J) = A(I,J) + X(IX)*TEMP1 - Y(IY)*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF + RETURN +C *** Last line of MB01ND *** + END diff --git a/mex/sources/libslicot/MB01PD.f b/mex/sources/libslicot/MB01PD.f new file mode 100644 index 000000000..1845ab8a8 --- /dev/null +++ b/mex/sources/libslicot/MB01PD.f @@ -0,0 +1,271 @@ + SUBROUTINE MB01PD( SCUN, TYPE, M, N, KL, KU, ANRM, NBL, NROWS, A, + $ LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To scale a matrix or undo scaling. Scaling is performed, if +C necessary, so that the matrix norm will be in a safe range of +C representable numbers. +C +C ARGUMENTS +C +C Mode Parameters +C +C SCUN CHARACTER*1 +C SCUN indicates the operation to be performed. +C = 'S': scale the matrix. +C = 'U': undo scaling of the matrix. +C +C TYPE CHARACTER*1 +C TYPE indicates the storage type of the input matrix. +C = 'G': A is a full matrix. +C = 'L': A is a (block) lower triangular matrix. +C = 'U': A is an (block) upper triangular matrix. +C = 'H': A is an (block) upper Hessenberg matrix. +C = 'B': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C lower half stored. +C = 'Q': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C upper half stored. +C = 'Z': A is a band matrix with lower bandwidth KL and +C upper bandwidth KU. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C KL (input) INTEGER +C The lower bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C KU (input) INTEGER +C The upper bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C ANRM (input) DOUBLE PRECISION +C The norm of the initial matrix A. ANRM >= 0. +C When ANRM = 0 then an immediate return is effected. +C ANRM should be preserved between the call of the routine +C with SCUN = 'S' and the corresponding one with SCUN = 'U'. +C +C NBL (input) INTEGER +C The number of diagonal blocks of the matrix A, if it has a +C block structure. To specify that matrix A has no block +C structure, set NBL = 0. NBL >= 0. +C +C NROWS (input) INTEGER array, dimension max(1,NBL) +C NROWS(i) contains the number of rows and columns of the +C i-th diagonal block of matrix A. The sum of the values +C NROWS(i), for i = 1: NBL, should be equal to min(M,N). +C The elements of the array NROWS are not referenced if +C NBL = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M by N part of this array must +C contain the matrix to be scaled/unscaled. +C On exit, the leading M by N part of A will contain +C the modified matrix. +C The storage mode of A is specified by TYPE. +C +C LDA (input) INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Error Indicator +C +C INFO (output) INTEGER +C = 0: successful exit +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Denote by ANRM the norm of the matrix, and by SMLNUM and BIGNUM, +C two positive numbers near the smallest and largest safely +C representable numbers, respectively. The matrix is scaled, if +C needed, such that the norm of the result is in the range +C [SMLNUM, BIGNUM]. The scaling factor is represented as a ratio +C of two numbers, one of them being ANRM, and the other one either +C SMLNUM or BIGNUM, depending on ANRM being less than SMLNUM or +C larger than BIGNUM, respectively. For undoing the scaling, the +C norm is again compared with SMLNUM or BIGNUM, and the reciprocal +C of the previous scaling factor is used. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C REVISIONS +C +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SCUN, TYPE + INTEGER INFO, KL, KU, LDA, M, MN, N, NBL + DOUBLE PRECISION ANRM +C .. Array Arguments .. + INTEGER NROWS ( * ) + DOUBLE PRECISION A( LDA, * ) +C .. Local Scalars .. + LOGICAL FIRST, LSCALE + INTEGER I, ISUM, ITYPE + DOUBLE PRECISION BIGNUM, SMLNUM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, MB01QD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Save statement .. + SAVE BIGNUM, FIRST, SMLNUM +C .. Data statements .. + DATA FIRST/.TRUE./ +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSCALE = LSAME( SCUN, 'S' ) + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +C + MN = MIN( M, N ) +C + ISUM = 0 + IF( NBL.GT.0 ) THEN + DO 10 I = 1, NBL + ISUM = ISUM + NROWS(I) + 10 CONTINUE + END IF +C + IF( .NOT.LSCALE .AND. .NOT.LSAME( SCUN, 'U' ) ) THEN + INFO = -1 + ELSE IF( ITYPE.EQ.-1 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. N.NE.M ) ) THEN + INFO = -4 + ELSE IF( ANRM.LT.ZERO ) THEN + INFO = -7 + ELSE IF( NBL.LT.0 ) THEN + INFO = -8 + ELSE IF( NBL.GT.0 .AND. ISUM.NE.MN ) THEN + INFO = -9 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -5 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -6 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -11 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MN.EQ.0 .OR. ANRM.EQ.ZERO ) + $ RETURN +C + IF ( FIRST ) THEN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + FIRST = .FALSE. + END IF +C + IF ( LSCALE ) THEN +C +C Scale A, if its norm is outside range [SMLNUM,BIGNUM]. +C + IF( ANRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL MB01QD( TYPE, M, N, KL, KU, ANRM, SMLNUM, NBL, NROWS, + $ A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL MB01QD( TYPE, M, N, KL, KU, ANRM, BIGNUM, NBL, NROWS, + $ A, LDA, INFO ) + END IF +C + ELSE +C +C Undo scaling. +C + IF( ANRM.LT.SMLNUM ) THEN + CALL MB01QD( TYPE, M, N, KL, KU, SMLNUM, ANRM, NBL, NROWS, + $ A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + CALL MB01QD( TYPE, M, N, KL, KU, BIGNUM, ANRM, NBL, NROWS, + $ A, LDA, INFO ) + END IF + END IF +C + RETURN +C *** Last line of MB01PD *** + END diff --git a/mex/sources/libslicot/MB01QD.f b/mex/sources/libslicot/MB01QD.f new file mode 100644 index 000000000..61befc51a --- /dev/null +++ b/mex/sources/libslicot/MB01QD.f @@ -0,0 +1,334 @@ + SUBROUTINE MB01QD( TYPE, M, N, KL, KU, CFROM, CTO, NBL, NROWS, A, + $ LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To multiply the M by N real matrix A by the real scalar CTO/CFROM. +C This is done without over/underflow as long as the final result +C CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that +C A may be full, (block) upper triangular, (block) lower triangular, +C (block) upper Hessenberg, or banded. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPE CHARACTER*1 +C TYPE indices the storage type of the input matrix. +C = 'G': A is a full matrix. +C = 'L': A is a (block) lower triangular matrix. +C = 'U': A is a (block) upper triangular matrix. +C = 'H': A is a (block) upper Hessenberg matrix. +C = 'B': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C lower half stored. +C = 'Q': A is a symmetric band matrix with lower bandwidth +C KL and upper bandwidth KU and with the only the +C upper half stored. +C = 'Z': A is a band matrix with lower bandwidth KL and +C upper bandwidth KU. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C KL (input) INTEGER +C The lower bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C KU (input) INTEGER +C The upper bandwidth of A. Referenced only if TYPE = 'B', +C 'Q' or 'Z'. +C +C CFROM (input) DOUBLE PRECISION +C CTO (input) DOUBLE PRECISION +C The matrix A is multiplied by CTO/CFROM. A(I,J) is +C computed without over/underflow if the final result +C CTO*A(I,J)/CFROM can be represented without over/ +C underflow. CFROM must be nonzero. +C +C NBL (input) INTEGER +C The number of diagonal blocks of the matrix A, if it has a +C block structure. To specify that matrix A has no block +C structure, set NBL = 0. NBL >= 0. +C +C NROWS (input) INTEGER array, dimension max(1,NBL) +C NROWS(i) contains the number of rows and columns of the +C i-th diagonal block of matrix A. The sum of the values +C NROWS(i), for i = 1: NBL, should be equal to min(M,N). +C The array NROWS is not referenced if NBL = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C The matrix to be multiplied by CTO/CFROM. See TYPE for +C the storage type. +C +C LDA (input) INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Error Indicator +C +C INFO INTEGER +C Not used in this implementation. +C +C METHOD +C +C Matrix A is multiplied by the real scalar CTO/CFROM, taking into +C account the specified storage mode of the matrix. +C MB01QD is a version of the LAPACK routine DLASCL, modified for +C dealing with block triangular, or block Hessenberg matrices. +C For efficiency, no tests of the input scalar parameters are +C performed. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N, NBL + DOUBLE PRECISION CFROM, CTO +C .. +C .. Array Arguments .. + INTEGER NROWS ( * ) + DOUBLE PRECISION A( LDA, * ) +C .. +C .. Local Scalars .. + LOGICAL DONE, NOBLC + INTEGER I, IFIN, ITYPE, J, JFIN, JINI, K, K1, K2, K3, + $ K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE + ITYPE = 6 + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) + $ RETURN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +C + CFROMC = CFROM + CTOC = CTO +C + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + CTO1 = CTOC / BIGNUM + IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF +C + NOBLC = NBL.EQ.0 +C + IF( ITYPE.EQ.0 ) THEN +C +C Full matrix +C + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +C + ELSE IF( ITYPE.EQ.1 ) THEN +C + IF ( NOBLC ) THEN +C +C Lower triangular matrix +C + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +C + ELSE +C +C Block lower triangular matrix +C + JFIN = 0 + DO 80 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) + DO 70 J = JINI, JFIN + DO 60 I = JINI, M + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.2 ) THEN +C + IF ( NOBLC ) THEN +C +C Upper triangular matrix +C + DO 100 J = 1, N + DO 90 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 90 CONTINUE + 100 CONTINUE +C + ELSE +C +C Block upper triangular matrix +C + JFIN = 0 + DO 130 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) + IF ( K.EQ.NBL ) JFIN = N + DO 120 J = JINI, JFIN + DO 110 I = 1, MIN( JFIN, M ) + A( I, J ) = A( I, J )*MUL + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.3 ) THEN +C + IF ( NOBLC ) THEN +C +C Upper Hessenberg matrix +C + DO 150 J = 1, N + DO 140 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +C + ELSE +C +C Block upper Hessenberg matrix +C + JFIN = 0 + DO 180 K = 1, NBL + JINI = JFIN + 1 + JFIN = JFIN + NROWS( K ) +C + IF ( K.EQ.NBL ) THEN + JFIN = N + IFIN = N + ELSE + IFIN = JFIN + NROWS( K+1 ) + END IF +C + DO 170 J = JINI, JFIN + DO 160 I = 1, MIN( IFIN, M ) + A( I, J ) = A( I, J )*MUL + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + END IF +C + ELSE IF( ITYPE.EQ.4 ) THEN +C +C Lower half of a symmetric band matrix +C + K3 = KL + 1 + K4 = N + 1 + DO 200 J = 1, N + DO 190 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 190 CONTINUE + 200 CONTINUE +C + ELSE IF( ITYPE.EQ.5 ) THEN +C +C Upper half of a symmetric band matrix +C + K1 = KU + 2 + K3 = KU + 1 + DO 220 J = 1, N + DO 210 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 210 CONTINUE + 220 CONTINUE +C + ELSE IF( ITYPE.EQ.6 ) THEN +C +C Band matrix +C + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 240 J = 1, N + DO 230 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 230 CONTINUE + 240 CONTINUE +C + END IF +C + IF( .NOT.DONE ) + $ GO TO 10 +C + RETURN +C *** Last line of MB01QD *** + END diff --git a/mex/sources/libslicot/MB01RD.f b/mex/sources/libslicot/MB01RD.f new file mode 100644 index 000000000..2c53070de --- /dev/null +++ b/mex/sources/libslicot/MB01RD.f @@ -0,0 +1,345 @@ + SUBROUTINE MB01RD( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, + $ X, LDX, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix formula +C _ +C R = alpha*R + beta*op( A )*X*op( A )', +C _ +C where alpha and beta are scalars, R, X, and R are symmetric +C matrices, A is a general matrix, and op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 _ +C Specifies which triangles of the symmetric matrices R, R, +C and X are given as follows: +C = 'U': the upper triangular part is given; +C = 'L': the lower triangular part is given. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C M (input) INTEGER _ +C The order of the matrices R and R and the number of rows +C of the matrix op( A ). M >= 0. +C +C N (input) INTEGER +C The order of the matrix X and the number of columns of the +C the matrix op( A ). N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then R need not be +C set before entry, except when R is identified with X in +C the call (which is possible only in this case). +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then A and X are not +C referenced. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry with UPLO = 'U', the leading M-by-M upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix R; the strictly +C lower triangular part of the array is used as workspace. +C On entry with UPLO = 'L', the leading M-by-M lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix R; the strictly +C upper triangular part of the array is used as workspace. +C On exit, the leading M-by-M upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. If beta <> 0, the remaining +C strictly triangular part of this array contains the +C corresponding part of the matrix expression +C beta*op( A )*T*op( A )', where T is the triangular matrix +C defined in the Method section. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k) +C where k is N when TRANS = 'N' and is M when TRANS = 'T' or +C TRANS = 'C'. +C On entry with TRANS = 'N', the leading M-by-N part of this +C array must contain the matrix A. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C N-by-M part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,l), +C where l is M when TRANS = 'N' and is N when TRANS = 'T' or +C TRANS = 'C'. +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix X and the strictly +C lower triangular part of the array is not referenced. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix X and the strictly +C upper triangular part of the array is not referenced. +C On exit, each diagonal element of this array has half its +C input value, but the other elements are not modified. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, the leading M-by-N part of this +C array (with the leading dimension MAX(1,M)) returns the +C matrix product beta*op( A )*T, where T is the triangular +C matrix defined in the Method section. +C This array is not referenced when beta = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,M*N), if beta <> 0; +C LDWORK >= 1, if beta = 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression is efficiently evaluated taking the symmetry +C into account. Specifically, let X = T + T', with T an upper or +C lower triangular matrix, defined by +C +C T = triu( X ) - (1/2)*diag( X ), if UPLO = 'U', +C T = tril( X ) - (1/2)*diag( X ), if UPLO = 'L', +C +C where triu, tril, and diag denote the upper triangular part, lower +C triangular part, and diagonal part of X, respectively. Then, +C +C op( A )*X*op( A )' = B + B', +C +C where B := op( A )*T*op( A )'. Matrix B is not symmetric, but it +C can be written as tri( B ) + stri( B ), where tri denotes the +C triangular part specified by UPLO, and stri denotes the remaining +C strictly triangular part. Let R = V + V', with V defined as T +C above. Then, the required triangular part of the result can be +C written as +C +C alpha*V + beta*tri( B ) + beta*(stri( B ))' + +C alpha*diag( V ) + beta*diag( tri( B ) ). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C +C 2 2 +C 3/2 x M x N + 1/2 x M +C +C operations. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004, +C Apr. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDR, LDWORK, LDX, M, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), R(LDR,*), X(LDX,*) +C .. Local Scalars .. + CHARACTER*12 NTRAN + LOGICAL LTRANS, LUPLO + INTEGER J, JWORK, LDW, NROWA +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASCL, DLASET, + $ DSCAL, DTRMM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF ( LTRANS ) THEN + NROWA = N + NTRAN = 'No transpose' + ELSE + NROWA = M + NTRAN = 'Transpose' + END IF +C + LDW = MAX( 1, M ) +C + IF( ( .NOT.LUPLO ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDR.LT.LDW ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( BETA.NE.ZERO .AND. LDWORK.LT.MAX( 1, M*N ) ) + $ .OR.( BETA.EQ.ZERO .AND. LDWORK.LT.1 ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + CALL DSCAL( N, HALF, X, LDX+1 ) + IF ( M.EQ.0 ) + $ RETURN +C + IF ( BETA.EQ.ZERO .OR. N.EQ.0 ) THEN + IF ( ALPHA.EQ.ZERO ) THEN +C +C Special case alpha = 0. +C + CALL DLASET( UPLO, M, M, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case beta = 0 or N = 0. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, M, M, R, LDR, INFO ) + END IF + RETURN + END IF +C +C General case: beta <> 0. Efficiently compute +C _ +C R = alpha*R + beta*op( A )*X*op( A )', +C +C as described in the Method section. +C +C Compute W = beta*op( A )*T in DWORK. +C Workspace: need M*N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code.) +C + IF( LTRANS ) THEN + JWORK = 1 +C + DO 10 J = 1, N + CALL DCOPY( M, A(J,1), LDA, DWORK(JWORK), 1 ) + JWORK = JWORK + LDW + 10 CONTINUE +C + ELSE + CALL DLACPY( 'Full', M, N, A, LDA, DWORK, LDW ) + END IF +C + CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit', M, N, BETA, + $ X, LDX, DWORK, LDW ) +C +C Compute Y = alpha*V + W*op( A )' in R. First, set to zero the +C strictly triangular part of R not specified by UPLO. That part +C will then contain beta*stri( B ). +C + IF ( ALPHA.NE.ZERO ) THEN + IF ( M.GT.1 ) THEN + IF ( LUPLO ) THEN + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, R(2,1), LDR ) + ELSE + CALL DLASET( 'Upper', M-1, M-1, ZERO, ZERO, R(1,2), LDR ) + END IF + END IF + CALL DSCAL( M, HALF, R, LDR+1 ) + END IF +C + CALL DGEMM( 'No transpose', NTRAN, M, M, N, ONE, DWORK, LDW, A, + $ LDA, ALPHA, R, LDR ) +C +C Add the term corresponding to B', with B = op( A )*T*op( A )'. +C + IF( LUPLO ) THEN +C + DO 20 J = 1, M + CALL DAXPY( J, ONE, R(J,1), LDR, R(1,J), 1 ) + 20 CONTINUE +C + ELSE +C + DO 30 J = 1, M + CALL DAXPY( J, ONE, R(1,J), 1, R(J,1), LDR ) + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB01RD *** + END diff --git a/mex/sources/libslicot/MB01RU.f b/mex/sources/libslicot/MB01RU.f new file mode 100644 index 000000000..c22549cc7 --- /dev/null +++ b/mex/sources/libslicot/MB01RU.f @@ -0,0 +1,282 @@ + SUBROUTINE MB01RU( UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, A, LDA, + $ X, LDX, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/MB01RW.f b/mex/sources/libslicot/MB01RW.f new file mode 100644 index 000000000..1305d3ed4 --- /dev/null +++ b/mex/sources/libslicot/MB01RW.f @@ -0,0 +1,249 @@ + SUBROUTINE MB01RW( UPLO, TRANS, M, N, A, LDA, Z, LDZ, DWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the transformation of the symmetric matrix A by the +C matrix Z in the form +C +C A := op(Z)*A*op(Z)', +C +C where op(Z) is either Z or its transpose, Z'. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies whether the upper or lower triangle of A +C is stored: +C = 'U': Upper triangle of A is stored; +C = 'L': Lower triangle of A is stored. +C +C TRANS CHARACTER*1 +C Specifies whether op(Z) is Z or its transpose Z': +C = 'N': op(Z) = Z; +C = 'T': op(Z) = Z'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the resulting symmetric matrix op(Z)*A*op(Z)' +C and the number of rows of the matrix Z, if TRANS = 'N', +C or the number of columns of the matrix Z, if TRANS = 'T'. +C M >= 0. +C +C N (input) INTEGER +C The order of the symmetric matrix A and the number of +C columns of the matrix Z, if TRANS = 'N', or the number of +C rows of the matrix Z, if TRANS = 'T'. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,MAX(M,N)) +C On entry, the leading N-by-N upper or lower triangular +C part of this array must contain the upper (UPLO = 'U') +C or lower (UPLO = 'L') triangular part of the symmetric +C matrix A. +C On exit, the leading M-by-M upper or lower triangular +C part of this array contains the upper (UPLO = 'U') or +C lower (UPLO = 'L') triangular part of the symmetric +C matrix op(Z)*A*op(Z)'. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,M,N). +C +C Z (input) DOUBLE PRECISION array, dimension (LDQ,K) +C where K = N if TRANS = 'N' and K = M if TRANS = 'T'. +C The leading M-by-N part, if TRANS = 'N', or N-by-M part, +C if TRANS = 'T', of this array contains the matrix Z. +C +C LDZ INTEGER +C The leading dimension of the array Z. +C LDZ >= MAX(1,M) if TRANS = 'N' and +C LDZ >= MAX(1,N) if TRANS = 'T'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C FURTHER COMMENTS +C +C This is a simpler, BLAS 2 version for MB01RD. +C +C CONTRIBUTOR +C +C A. Varga, DLR, Feb. 1995. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDZ, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL NOTTRA, UPPER + INTEGER I, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements +C + NOTTRA = LSAME( TRANS, 'N' ) + UPPER = LSAME( UPLO, 'U' ) +C + INFO = 0 + IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOTTRA .OR. LSAME( TRANS, 'T') ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M, N ) ) THEN + INFO = -6 + ELSE IF( ( NOTTRA .AND. LDZ.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.NOTTRA .AND. LDZ.LT.MAX( 1, N ) ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB01RW', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( NOTTRA ) THEN +C +C Compute Z*A*Z'. +C + IF ( UPPER ) THEN +C +C Compute Z*A in A (M-by-N). +C + DO 10 J = 1, N + CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) + CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) + CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(1,J), 1 ) + 10 CONTINUE +C +C Compute A*Z' in the upper triangular part of A. +C + DO 20 I = 1, M + CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) + CALL DGEMV( TRANS, M-I+1, N, ONE, Z(I,1), LDZ, DWORK, 1, + $ ZERO, A(I,I), LDA ) + 20 CONTINUE +C + ELSE +C +C Compute A*Z' in A (N-by-M). +C + DO 30 I = 1, N + CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) + CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) + CALL DGEMV( TRANS, M, N, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(I,1), LDA ) + 30 CONTINUE +C +C Compute Z*A in the lower triangular part of A. +C + DO 40 J = 1, M + CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) + CALL DGEMV( TRANS, M-J+1, N, ONE, Z(J,1), LDZ, DWORK, 1, + $ ZERO, A(J,J), 1 ) + 40 CONTINUE +C + END IF + ELSE +C +C Compute Z'*A*Z. +C + IF ( UPPER ) THEN +C +C Compute Z'*A in A (M-by-N). +C + DO 50 J = 1, N + CALL DCOPY( J-1, A(1,J), 1, DWORK, 1 ) + CALL DCOPY( N-J+1, A(J,J), LDA, DWORK(J), 1 ) + CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(1,J), 1 ) + 50 CONTINUE +C +C Compute A*Z in the upper triangular part of A. +C + DO 60 I = 1, M + CALL DCOPY( N, A(I,1), LDA, DWORK, 1 ) + CALL DGEMV( TRANS, N, M-I+1, ONE, Z(1,I), LDZ, DWORK, 1, + $ ZERO, A(I,I), LDA ) + 60 CONTINUE +C + ELSE +C +C Compute A*Z in A (N-by-M). +C + DO 70 I = 1, N + CALL DCOPY( I-1, A(I,1), LDA, DWORK, 1 ) + CALL DCOPY( N-I+1, A(I,I), 1, DWORK(I), 1 ) + CALL DGEMV( TRANS, N, M, ONE, Z, LDZ, DWORK, 1, ZERO, + $ A(I,1), LDA ) + 70 CONTINUE +C +C Compute Z'*A in the lower triangular part of A. +C + DO 80 J = 1, M + CALL DCOPY( N, A(1,J), 1, DWORK, 1 ) + CALL DGEMV( TRANS, N, M-J+1, ONE, Z(1,J), LDZ, DWORK, 1, + $ ZERO, A(J,J), 1 ) + 80 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of MB01RW *** + END diff --git a/mex/sources/libslicot/MB01RX.f b/mex/sources/libslicot/MB01RX.f new file mode 100644 index 000000000..64abe3901 --- /dev/null +++ b/mex/sources/libslicot/MB01RX.f @@ -0,0 +1,315 @@ + SUBROUTINE MB01RX( SIDE, UPLO, TRANS, M, N, ALPHA, BETA, R, LDR, + $ A, LDA, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/MB01RY.f b/mex/sources/libslicot/MB01RY.f new file mode 100644 index 000000000..af32cfe63 --- /dev/null +++ b/mex/sources/libslicot/MB01RY.f @@ -0,0 +1,429 @@ + SUBROUTINE MB01RY( SIDE, UPLO, TRANS, M, ALPHA, BETA, R, LDR, H, + $ LDH, B, LDB, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/MB01SD.f b/mex/sources/libslicot/MB01SD.f new file mode 100644 index 000000000..b29437379 --- /dev/null +++ b/mex/sources/libslicot/MB01SD.f @@ -0,0 +1,123 @@ + SUBROUTINE MB01SD( JOBS, M, N, A, LDA, R, C ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/MB01TD.f b/mex/sources/libslicot/MB01TD.f new file mode 100644 index 000000000..d4e06e626 --- /dev/null +++ b/mex/sources/libslicot/MB01TD.f @@ -0,0 +1,173 @@ + SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product A * B, where A and B are upper +C quasi-triangular matrices (that is, block upper triangular with +C 1-by-1 or 2-by-2 diagonal blocks) with the same structure. +C The result is returned in the array B. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix A. The elements below the +C subdiagonal are not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix B, with the same +C structure as matrix A. +C On exit, the leading N-by-N part of this array contains +C the computed product A * B, with the same structure as +C on entry. +C The elements below the subdiagonal are not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N-1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrices A and B have not the same structure, +C and/or A and B are not upper quasi-triangular. +C +C METHOD +C +C The matrix product A * B is computed column by column, using +C BLAS 2 and BLAS 1 operations. +C +C FURTHER COMMENTS +C +C This routine can be used, for instance, for computing powers of +C a real Schur form matrix. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) +C .. Local Scalars .. + INTEGER I, J, JMIN, JMNM +C .. External Subroutines .. + EXTERNAL DAXPY, DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01TD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( N.EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.1 ) THEN + B(1,1) = A(1,1)*B(1,1) + RETURN + END IF +C +C Test the upper quasi-triangular structure of A and B for identity. +C + DO 10 I = 1, N - 1 + IF ( A(I+1,I).EQ.ZERO ) THEN + IF ( B(I+1,I).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + ELSE IF ( I.LT.N-1 ) THEN + IF ( A(I+2,I+1).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + END IF + 10 CONTINUE +C + DO 30 J = 1, N + JMIN = MIN( J+1, N ) + JMNM = MIN( JMIN, N-1 ) +C +C Compute the contribution of the subdiagonal of A to the +C j-th column of the product. +C + DO 20 I = 1, JMNM + DWORK(I) = A(I+1,I)*B(I,J) + 20 CONTINUE +C +C Multiply the upper triangle of A by the j-th column of B, +C and add to the above result. +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', JMIN, A, LDA, + $ B(1,J), 1 ) + CALL DAXPY( JMNM, ONE, DWORK, 1, B(2,J), 1 ) + 30 CONTINUE +C + RETURN +C *** Last line of MB01TD *** + END diff --git a/mex/sources/libslicot/MB01UD.f b/mex/sources/libslicot/MB01UD.f new file mode 100644 index 000000000..0bdacadf5 --- /dev/null +++ b/mex/sources/libslicot/MB01UD.f @@ -0,0 +1,238 @@ + SUBROUTINE MB01UD( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, B, + $ LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/MB01UW.f b/mex/sources/libslicot/MB01UW.f new file mode 100644 index 000000000..ff8489636 --- /dev/null +++ b/mex/sources/libslicot/MB01UW.f @@ -0,0 +1,377 @@ + SUBROUTINE MB01UW( SIDE, TRANS, M, N, ALPHA, H, LDH, A, LDA, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute one of the matrix products +C +C A : = alpha*op( H ) * A, or A : = alpha*A * op( H ), +C +C where alpha is a scalar, A is an m-by-n matrix, H is an upper +C Hessenberg matrix, and op( H ) is one of +C +C op( H ) = H or op( H ) = H', the transpose of H. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the Hessenberg matrix H appears on the +C left or right in the matrix product as follows: +C = 'L': A := alpha*op( H ) * A; +C = 'R': A := alpha*A * op( H ). +C +C TRANS CHARACTER*1 +C Specifies the form of op( H ) to be used in the matrix +C multiplication as follows: +C = 'N': op( H ) = H; +C = 'T': op( H ) = H'; +C = 'C': op( H ) = H'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then H is not +C referenced and A need not be set before entry. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,k) +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with SIDE = 'L', the leading M-by-M upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C On entry with SIDE = 'R', the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C Hessenberg matrix H. +C The elements below the subdiagonal are not referenced, +C except possibly for those in the first column, which +C could be overwritten, but are restored on exit. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix A. +C On exit, the leading M-by-N part of this array contains +C the computed product. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, alpha <> 0, and LDWORK >= M*N > 0, +C DWORK contains a copy of the matrix A, having the leading +C dimension M. +C This array is not referenced when alpha = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= 0, if alpha = 0 or MIN(M,N) = 0; +C LDWORK >= M-1, if SIDE = 'L'; +C LDWORK >= N-1, if SIDE = 'R'. +C For maximal efficiency LDWORK should be at least M*N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The required matrix product is computed in two steps. In the first +C step, the upper triangle of H is used; in the second step, the +C contribution of the subdiagonal is added. If the workspace can +C accomodate a copy of A, a fast BLAS 3 DTRMM operation is used in +C the first step. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, January 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, LDA, LDH, LDWORK, M, N + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), H(LDH,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRANS + INTEGER I, J, JW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLASCL, DLASET, DSCAL, DSWAP, + $ DTRMM, DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) )THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.1 .OR. ( LSIDE .AND. LDH.LT.M ) .OR. + $ ( .NOT.LSIDE .AND. LDH.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDWORK.LT.0 .OR. + $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. + $ ( ( LSIDE .AND. LDWORK.LT.M-1 ) .OR. + $ ( .NOT.LSIDE .AND. LDWORK.LT.N-1 ) ) ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01UW', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( MIN( M, N ).EQ.0 ) THEN + RETURN + ELSE IF ( LSIDE ) THEN + IF ( M.EQ.1 ) THEN + CALL DSCAL( N, ALPHA*H(1,1), A, LDA ) + RETURN + END IF + ELSE + IF ( N.EQ.1 ) THEN + CALL DSCAL( M, ALPHA*H(1,1), A, 1 ) + RETURN + END IF + END IF +C + IF( ALPHA.EQ.ZERO ) THEN +C +C Set A to zero and return. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) + RETURN + END IF +C + IF( LDWORK.GE.M*N ) THEN +C +C Enough workspace for a fast BLAS 3 calculation. +C Save A in the workspace and compute one of the matrix products +C A : = alpha*op( triu( H ) ) * A, or +C A : = alpha*A * op( triu( H ) ), +C involving the upper triangle of H. +C + CALL DLACPY( 'Full', M, N, A, LDA, DWORK, M ) + CALL DTRMM( SIDE, 'Upper', TRANS, 'Non-unit', M, N, ALPHA, H, + $ LDH, A, LDA ) +C +C Add the contribution of the subdiagonal of H. +C If SIDE = 'L', the subdiagonal of H is swapped with the +C corresponding elements in the first column of H, and the +C calculations are organized for column operations. +C + IF( LSIDE ) THEN + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + JW = 1 + DO 20 J = 1, N + JW = JW + 1 + DO 10 I = 1, M - 1 + A( I, J ) = A( I, J ) + + $ ALPHA*H( I+1, 1 )*DWORK( JW ) + JW = JW + 1 + 10 CONTINUE + 20 CONTINUE + ELSE + JW = 0 + DO 40 J = 1, N + JW = JW + 1 + DO 30 I = 2, M + A( I, J ) = A( I, J ) + + $ ALPHA*H( I, 1 )*DWORK( JW ) + JW = JW + 1 + 30 CONTINUE + 40 CONTINUE + END IF + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C + IF( LTRANS ) THEN + JW = 1 + DO 50 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, + $ A( 1, J+1 ), 1 ) + JW = JW + M + 50 CONTINUE + ELSE + JW = M + 1 + DO 60 J = 1, N - 1 + IF ( H( J+1, J ).NE.ZERO ) + $ CALL DAXPY( M, ALPHA*H( J+1, J ), DWORK( JW ), 1, + $ A( 1, J ), 1 ) + JW = JW + M + 60 CONTINUE + END IF + END IF +C + ELSE +C +C Use a BLAS 2 calculation. +C + IF( LSIDE ) THEN + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + DO 80 J = 1, N +C +C Compute the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 70 I = 1, M - 1 + DWORK( I ) = H( I+1, 1 )*A( I+1, J ) + 70 CONTINUE +C +C Multiply the upper triangle of H by the j-th column +C of A, and add to the above result. +C + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, + $ A( 1, J ), 1 ) + CALL DAXPY( M-1, ONE, DWORK, 1, A( 1, J ), 1 ) + 80 CONTINUE +C + ELSE + DO 100 J = 1, N +C +C Compute the contribution of the subdiagonal of H to +C the j-th column of the product. +C + DO 90 I = 1, M - 1 + DWORK( I ) = H( I+1, 1 )*A( I, J ) + 90 CONTINUE +C +C Multiply the upper triangle of H by the j-th column +C of A, and add to the above result. +C + CALL DTRMV( 'Upper', TRANS, 'Non-unit', M, H, LDH, + $ A( 1, J ), 1 ) + CALL DAXPY( M-1, ONE, DWORK, 1, A( 2, J ), 1 ) + 100 CONTINUE + END IF + IF( M.GT.2 ) + $ CALL DSWAP( M-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + ELSE +C +C Below, row-wise calculations are used for A. +C + IF( N.GT.2 ) + $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) + IF( LTRANS ) THEN + DO 120 I = 1, M +C +C Compute the contribution of the subdiagonal of H to +C the i-th row of the product. +C + DO 110 J = 1, N - 1 + DWORK( J ) = A( I, J )*H( J+1, 1 ) + 110 CONTINUE +C +C Multiply the i-th row of A by the upper triangle of H, +C and add to the above result. +C + CALL DTRMV( 'Upper', 'NoTranspose', 'Non-unit', N, H, + $ LDH, A( I, 1 ), LDA ) + CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 2 ), LDA ) + 120 CONTINUE +C + ELSE + DO 140 I = 1, M +C +C Compute the contribution of the subdiagonal of H to +C the i-th row of the product. +C + DO 130 J = 1, N - 1 + DWORK( J ) = A( I, J+1 )*H( J+1, 1 ) + 130 CONTINUE +C +C Multiply the i-th row of A by the upper triangle of H, +C and add to the above result. +C + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', N, H, + $ LDH, A( I, 1 ), LDA ) + CALL DAXPY( N-1, ONE, DWORK, 1, A( I, 1 ), LDA ) + 140 CONTINUE + END IF + IF( N.GT.2 ) + $ CALL DSWAP( N-2, H( 3, 2 ), LDH+1, H( 3, 1 ), 1 ) +C + END IF +C +C Scale the result by alpha. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, + $ INFO ) + END IF + RETURN +C *** Last line of MB01UW *** + END diff --git a/mex/sources/libslicot/MB01UX.f b/mex/sources/libslicot/MB01UX.f new file mode 100644 index 000000000..166c23c44 --- /dev/null +++ b/mex/sources/libslicot/MB01UX.f @@ -0,0 +1,373 @@ + SUBROUTINE MB01UX( SIDE, UPLO, TRANS, M, N, ALPHA, T, LDT, A, LDA, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute one of the matrix products +C +C A : = alpha*op( T ) * A, or A : = alpha*A * op( T ), +C +C where alpha is a scalar, A is an m-by-n matrix, T is a quasi- +C triangular matrix, and op( T ) is one of +C +C op( T ) = T or op( T ) = T', the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the upper quasi-triangular matrix H +C appears on the left or right in the matrix product as +C follows: +C = 'L': A := alpha*op( T ) * A; +C = 'R': A := alpha*A * op( T ). +C +C UPLO CHARACTER*1. +C Specifies whether the matrix T is an upper or lower +C quasi-triangular matrix as follows: +C = 'U': T is an upper quasi-triangular matrix; +C = 'L': T is a lower quasi-triangular matrix. +C +C TRANS CHARACTER*1 +C Specifies the form of op( T ) to be used in the matrix +C multiplication as follows: +C = 'N': op( T ) = T; +C = 'T': op( T ) = T'; +C = 'C': op( T ) = T'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then T is not +C referenced and A need not be set before entry. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,k) +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with UPLO = 'U', the leading k-by-k upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T. The elements below the +C subdiagonal are not referenced. +C On entry with UPLO = 'L', the leading k-by-k lower +C Hessenberg part of this array must contain the lower +C quasi-triangular matrix T. The elements above the +C supdiagonal are not referenced. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix A. +C On exit, the leading M-by-N part of this array contains +C the computed product. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 and ALPHA<>0, DWORK(1) returns the +C optimal value of LDWORK. +C On exit, if INFO = -12, DWORK(1) returns the minimum +C value of LDWORK. +C This array is not referenced when alpha = 0. +C +C LDWORK The length of the array DWORK. +C LDWORK >= 1, if alpha = 0 or MIN(M,N) = 0; +C LDWORK >= 2*(M-1), if SIDE = 'L'; +C LDWORK >= 2*(N-1), if SIDE = 'R'. +C For maximal efficiency LDWORK should be at least +C NOFF*N + M - 1, if SIDE = 'L'; +C NOFF*M + N - 1, if SIDE = 'R'; +C where NOFF is the number of nonzero elements on the +C subdiagonal (if UPLO = 'U') or supdiagonal (if UPLO = 'L') +C of T. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The technique used in this routine is similiar to the technique +C used in the SLICOT [1] subroutine MB01UW developed by Vasile Sima. +C The required matrix product is computed in two steps. In the first +C step, the triangle of T specified by UPLO is used; in the second +C step, the contribution of the sub-/supdiagonal is added. If the +C workspace can accommodate parts of A, a fast BLAS 3 DTRMM +C operation is used in the first step. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., Sima, V., Van Huffel, S., and +C Varga, A. +C SLICOT - A subroutine library in systems and control theory. +C In: Applied and computational control, signals, and circuits, +C Vol. 1, pp. 499-539, Birkhauser, Boston, 1999. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTRQML). +C +C KEYWORDS +C +C Elementary matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDA, LDT, LDWORK, M, N + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), T(LDT,*) +C .. Local Scalars .. + LOGICAL LSIDE, LTRAN, LUP + CHARACTER ATRAN + INTEGER I, IERR, J, K, NOFF, PDW, PSAV, WRKMIN, WRKOPT, + $ XDIF + DOUBLE PRECISION TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLASCL, DLASET, DTRMM, DTRMV, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Decode and test the input scalar arguments. +C + INFO = 0 + LSIDE = LSAME( SIDE, 'L' ) + LUP = LSAME( UPLO, 'U' ) + LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + IF ( LSIDE ) THEN + K = M + ELSE + K = N + END IF + WRKMIN = 2*( K - 1 ) +C + IF ( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( ( .NOT.LUP ).AND.( .NOT.LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSE IF ( ( .NOT.LTRAN ).AND.( .NOT.LSAME( TRANS, 'N' ) ) ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDT.LT.MAX( 1, K ) ) THEN + INFO = -8 + ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF ( LDWORK.LT.0 .OR. + $ ( ALPHA.NE.ZERO .AND. MIN( M, N ).GT.0 .AND. + $ LDWORK.LT.WRKMIN ) ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01UX', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF ( MIN( M, N ).EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN +C +C Set A to zero and return. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) + RETURN + END IF +C +C Save and count off-diagonal entries of T. +C + IF ( LUP ) THEN + CALL DCOPY( K-1, T(2,1), LDT+1, DWORK, 1 ) + ELSE + CALL DCOPY( K-1, T(1,2), LDT+1, DWORK, 1 ) + END IF + NOFF = 0 + DO 5 I = 1, K-1 + IF ( DWORK(I).NE.ZERO ) + $ NOFF = NOFF + 1 + 5 CONTINUE +C +C Compute optimal workspace. +C + IF ( LSIDE ) THEN + WRKOPT = NOFF*N + M - 1 + ELSE + WRKOPT = NOFF*M + N - 1 + END IF + PSAV = K + IF ( .NOT.LTRAN ) THEN + XDIF = 0 + ELSE + XDIF = 1 + END IF + IF ( .NOT.LUP ) + $ XDIF = 1 - XDIF + IF ( .NOT.LSIDE ) + $ XDIF = 1 - XDIF +C + IF ( LDWORK.GE.WRKOPT ) THEN +C +C Enough workspace for a fast BLAS 3 calculation. +C Save relevant parts of A in the workspace and compute one of +C the matrix products +C A : = alpha*op( triu( T ) ) * A, or +C A : = alpha*A * op( triu( T ) ), +C involving the upper/lower triangle of T. +C + PDW = PSAV + IF ( LSIDE ) THEN + DO 20 J = 1, N + DO 10 I = 1, M-1 + IF ( DWORK(I).NE.ZERO ) THEN + DWORK(PDW) = A(I+XDIF,J) + PDW = PDW + 1 + END IF + 10 CONTINUE + 20 CONTINUE + ELSE + DO 30 J = 1, N-1 + IF ( DWORK(J).NE.ZERO ) THEN + CALL DCOPY( M, A(1,J+XDIF), 1, DWORK(PDW), 1 ) + PDW = PDW + M + END IF + 30 CONTINUE + END IF + CALL DTRMM( SIDE, UPLO, TRANS, 'Non-unit', M, N, ALPHA, T, + $ LDT, A, LDA ) +C +C Add the contribution of the offdiagonal of T. +C + PDW = PSAV + XDIF = 1 - XDIF + IF( LSIDE ) THEN + DO 50 J = 1, N + DO 40 I = 1, M-1 + TEMP = DWORK(I) + IF ( TEMP.NE.ZERO ) THEN + A(I+XDIF,J) = A(I+XDIF,J) + ALPHA * TEMP * + $ DWORK(PDW) + PDW = PDW + 1 + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 60 J = 1, N-1 + TEMP = DWORK(J)*ALPHA + IF ( TEMP.NE.ZERO ) THEN + CALL DAXPY( M, TEMP, DWORK(PDW), 1, A(1,J+XDIF), 1 ) + PDW = PDW + M + END IF + 60 CONTINUE + END IF + ELSE +C +C Use a BLAS 2 calculation. +C + IF ( LSIDE ) THEN + DO 80 J = 1, N +C +C Compute the contribution of the offdiagonal of T to +C the j-th column of the product. +C + DO 70 I = 1, M - 1 + DWORK(PSAV+I-1) = DWORK(I)*A(I+XDIF,J) + 70 CONTINUE +C +C Multiply the triangle of T by the j-th column of A, +C and add to the above result. +C + CALL DTRMV( UPLO, TRANS, 'Non-unit', M, T, LDT, A(1,J), + $ 1 ) + CALL DAXPY( M-1, ONE, DWORK(PSAV), 1, A(2-XDIF,J), 1 ) + 80 CONTINUE + ELSE + IF ( LTRAN ) THEN + ATRAN = 'N' + ELSE + ATRAN = 'T' + END IF + DO 100 I = 1, M +C +C Compute the contribution of the offdiagonal of T to +C the i-th row of the product. +C + DO 90 J = 1, N - 1 + DWORK(PSAV+J-1) = A(I,J+XDIF)*DWORK(J) + 90 CONTINUE +C +C Multiply the i-th row of A by the triangle of T, +C and add to the above result. +C + CALL DTRMV( UPLO, ATRAN, 'Non-unit', N, T, LDT, A(I,1), + $ LDA ) + CALL DAXPY( N-1, ONE, DWORK(PSAV), 1, A(I,2-XDIF), LDA ) + 100 CONTINUE + END IF +C +C Scale the result by alpha. +C + IF ( ALPHA.NE.ONE ) + $ CALL DLASCL( 'General', 0, 0, ONE, ALPHA, M, N, A, LDA, + $ IERR ) + END IF + DWORK(1) = DBLE( MAX( WRKMIN, WRKOPT ) ) + RETURN +C *** Last line of MB01UX *** + END diff --git a/mex/sources/libslicot/MB01VD.f b/mex/sources/libslicot/MB01VD.f new file mode 100644 index 000000000..bcd924d68 --- /dev/null +++ b/mex/sources/libslicot/MB01VD.f @@ -0,0 +1,1693 @@ + SUBROUTINE MB01VD( TRANA, TRANB, MA, NA, MB, NB, ALPHA, BETA, + $ A, LDA, B, LDB, C, LDC, MC, NC, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the following matrix operation +C +C C = alpha*kron( op(A), op(B) ) + beta*C, +C +C where alpha and beta are real scalars, op(M) is either matrix M or +C its transpose, M', and kron( X, Y ) denotes the Kronecker product +C of the matrices X and Y. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used as follows: +C = 'N': op(A) = A; +C = 'T': op(A) = A'; +C = 'C': op(A) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op(B) to be used as follows: +C = 'N': op(B) = B; +C = 'T': op(B) = B'; +C = 'C': op(B) = B'. +C +C Input/Output Parameters +C +C MA (input) INTEGER +C The number of rows of the matrix op(A). MA >= 0. +C +C NA (input) INTEGER +C The number of columns of the matrix op(A). NA >= 0. +C +C MB (input) INTEGER +C The number of rows of the matrix op(B). MB >= 0. +C +C NB (input) INTEGER +C The number of columns of the matrix op(B). NB >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then A and B need not +C be set before entry. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then C need not be +C set before entry. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,ka), +C where ka is NA when TRANA = 'N', and is MA otherwise. +C If TRANA = 'N', the leading MA-by-NA part of this array +C must contain the matrix A; otherwise, the leading NA-by-MA +C part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= max(1,MA), if TRANA = 'N'; +C LDA >= max(1,NA), if TRANA = 'T' or 'C'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,kb) +C where kb is NB when TRANB = 'N', and is MB otherwise. +C If TRANB = 'N', the leading MB-by-NB part of this array +C must contain the matrix B; otherwise, the leading NB-by-MB +C part of this array must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= max(1,MB), if TRANB = 'N'; +C LDB >= max(1,NB), if TRANB = 'T' or 'C'. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) +C On entry, if beta is nonzero, the leading MC-by-NC part of +C this array must contain the given matric C, where +C MC = MA*MB and NC = NA*NB. +C On exit, the leading MC-by-NC part of this array contains +C the computed matrix expression +C C = alpha*kron( op(A), op(B) ) + beta*C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= max(1,MC). +C +C MC (output) INTEGER +C The number of rows of the matrix C. MC = MA*MB. +C +C NC (output) INTEGER +C The number of columns of the matrix C. NC = NA*NB. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Kronecker product of the matrices op(A) and op(B) is computed +C column by column. +C +C FURTHER COMMENTS +C +C The multiplications by zero elements in A are avoided, if the +C matrix A is considered to be sparse, i.e., if +C (number of zeros in A)/(MA*NA) >= SPARST = 0.8. The code makes +C NB+1 passes through the matrix A, and MA*NA passes through the +C matrix B. If LDA and/or LDB are very large, and op(A) = A' and/or +C op(B) = B', it could be more efficient to transpose A and/or B +C before calling this routine, and use the 'N' values for TRANA +C and/or TRANB. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION SPARST + PARAMETER ( SPARST = 0.8D0 ) +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER INFO, LDA, LDB, LDC, MA, MB, MC, NA, NB, NC + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) +C .. Local Scalars .. + LOGICAL SPARSE, TRANSA, TRANSB + INTEGER I, IC, J, JC, K, L, LC, NZ + DOUBLE PRECISION AIJ +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLASET, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + TRANSA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + TRANSB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + MC = MA*MB + INFO = 0 + IF( .NOT.( TRANSA .OR. LSAME( TRANA, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( TRANSB .OR. LSAME( TRANB, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( MA.LT.0 ) THEN + INFO = -3 + ELSE IF( NA.LT.0 ) THEN + INFO = -4 + ELSE IF( MB.LT.0 ) THEN + INFO = -5 + ELSE IF( NB.LT.0 ) THEN + INFO = -6 + ELSE IF( ( TRANSA .AND. LDA.LT.NA ) .OR. LDA.LT.1 .OR. + $ ( .NOT.TRANSA .AND. LDA.LT.MA ) ) THEN + INFO = -10 + ELSE IF( ( TRANSB .AND. LDB.LT.NB ) .OR. LDB.LT.1 .OR. + $ ( .NOT.TRANSB .AND. LDB.LT.MB ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, MC ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01VD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + NC = NA*NB + IF ( MC.EQ.0 .OR. NC.EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN + IF ( BETA.EQ.ZERO ) THEN + CALL DLASET( 'Full', MC, NC, ZERO, ZERO, C, LDC ) + ELSE IF ( BETA.NE.ONE ) THEN +C + DO 10 J = 1, NC + CALL DSCAL( MC, BETA, C(1,J), 1 ) + 10 CONTINUE +C + END IF + RETURN + END IF +C + DUM(1) = ZERO + JC = 1 + NZ = 0 +C +C Compute the Kronecker product of the matrices op(A) and op(B), +C C = alpha*kron( op(A), op(B) ) + beta*C. +C First, check if A is sparse. Here, A is considered as being sparse +C if (number of zeros in A)/(MA*NA) >= SPARST. +C + DO 30 J = 1, NA +C + DO 20 I = 1, MA + IF ( TRANSA ) THEN + IF ( A(J,I).EQ.ZERO ) + $ NZ = NZ + 1 + ELSE + IF ( A(I,J).EQ.ZERO ) + $ NZ = NZ + 1 + END IF + 20 CONTINUE +C + 30 CONTINUE +C + SPARSE = DBLE( NZ )/DBLE( MA*NA ).GE.SPARST +C + IF ( .NOT.TRANSA .AND. .NOT.TRANSB ) THEN +C +C Case op(A) = A and op(B) = B. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 80 J = 1, NA +C + DO 70 K = 1, NB + IC = 1 +C + DO 60 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 50 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 50 CONTINUE +C + END IF + IC = IC + MB + 60 CONTINUE +C + JC = JC + 1 + 70 CONTINUE +C + 80 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 120 J = 1, NA +C + DO 110 K = 1, NB + IC = 1 +C + DO 100 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 90 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 90 CONTINUE +C + IC = IC + MB + 100 CONTINUE +C + JC = JC + 1 + 110 CONTINUE +C + 120 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 160 J = 1, NA +C + DO 150 K = 1, NB + IC = 1 +C + DO 140 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 130 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 130 CONTINUE +C + END IF + IC = IC + MB + 140 CONTINUE +C + JC = JC + 1 + 150 CONTINUE +C + 160 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 200 J = 1, NA +C + DO 190 K = 1, NB + IC = 1 +C + DO 180 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 170 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 170 CONTINUE +C + IC = IC + MB + 180 CONTINUE +C + JC = JC + 1 + 190 CONTINUE +C + 200 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 240 J = 1, NA +C + DO 230 K = 1, NB + IC = 1 +C + DO 220 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 210 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 210 CONTINUE +C + END IF + IC = IC + MB + 220 CONTINUE +C + JC = JC + 1 + 230 CONTINUE +C + 240 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 280 J = 1, NA +C + DO 270 K = 1, NB + IC = 1 +C + DO 260 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 250 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 250 CONTINUE +C + IC = IC + MB + 260 CONTINUE +C + JC = JC + 1 + 270 CONTINUE +C + 280 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 320 J = 1, NA +C + DO 310 K = 1, NB + IC = 1 +C + DO 300 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 290 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 290 CONTINUE +C + END IF + IC = IC + MB + 300 CONTINUE +C + JC = JC + 1 + 310 CONTINUE +C + 320 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 360 J = 1, NA +C + DO 350 K = 1, NB + IC = 1 +C + DO 340 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 330 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 330 CONTINUE +C + IC = IC + MB + 340 CONTINUE +C + JC = JC + 1 + 350 CONTINUE +C + 360 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 400 J = 1, NA +C + DO 390 K = 1, NB + IC = 1 +C + DO 380 I = 1, MA + AIJ = A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 370 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 370 CONTINUE +C + END IF + IC = IC + MB + 380 CONTINUE +C + JC = JC + 1 + 390 CONTINUE +C + 400 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 440 J = 1, NA +C + DO 430 K = 1, NB + IC = 1 +C + DO 420 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 410 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 410 CONTINUE +C + IC = IC + MB + 420 CONTINUE +C + JC = JC + 1 + 430 CONTINUE +C + 440 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 480 J = 1, NA +C + DO 470 K = 1, NB + IC = 1 +C + DO 460 I = 1, MA + AIJ = ALPHA*A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 450 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 450 CONTINUE +C + END IF + IC = IC + MB + 460 CONTINUE +C + JC = JC + 1 + 470 CONTINUE +C + 480 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 520 J = 1, NA +C + DO 510 K = 1, NB + IC = 1 +C + DO 500 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 490 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 490 CONTINUE +C + IC = IC + MB + 500 CONTINUE +C + JC = JC + 1 + 510 CONTINUE +C + 520 CONTINUE +C + END IF + END IF + END IF + ELSE IF ( TRANSA .AND. .NOT.TRANSB ) THEN +C +C Case op(A) = A' and op(B) = B. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 560 J = 1, NA +C + DO 550 K = 1, NB + IC = 1 +C + DO 540 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(1,K), 1, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 530 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 530 CONTINUE +C + END IF + IC = IC + MB + 540 CONTINUE +C + JC = JC + 1 + 550 CONTINUE +C + 560 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 600 J = 1, NA +C + DO 590 K = 1, NB + IC = 1 +C + DO 580 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 570 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 570 CONTINUE +C + IC = IC + MB + 580 CONTINUE +C + JC = JC + 1 + 590 CONTINUE +C + 600 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 640 J = 1, NA +C + DO 630 K = 1, NB + IC = 1 +C + DO 620 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 610 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 610 CONTINUE +C + END IF + IC = IC + MB + 620 CONTINUE +C + JC = JC + 1 + 630 CONTINUE +C + 640 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 680 J = 1, NA +C + DO 670 K = 1, NB + IC = 1 +C + DO 660 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 650 L = 1, MB + C(LC,JC) = AIJ*B(L,K) + LC = LC + 1 + 650 CONTINUE +C + IC = IC + MB + 660 CONTINUE +C + JC = JC + 1 + 670 CONTINUE +C + 680 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 720 J = 1, NA +C + DO 710 K = 1, NB + IC = 1 +C + DO 700 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 690 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 690 CONTINUE +C + END IF + IC = IC + MB + 700 CONTINUE +C + JC = JC + 1 + 710 CONTINUE +C + 720 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 760 J = 1, NA +C + DO 750 K = 1, NB + IC = 1 +C + DO 740 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 730 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 730 CONTINUE +C + IC = IC + MB + 740 CONTINUE +C + JC = JC + 1 + 750 CONTINUE +C + 760 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 800 J = 1, NA +C + DO 790 K = 1, NB + IC = 1 +C + DO 780 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 770 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 770 CONTINUE +C + END IF + IC = IC + MB + 780 CONTINUE +C + JC = JC + 1 + 790 CONTINUE +C + 800 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 840 J = 1, NA +C + DO 830 K = 1, NB + IC = 1 +C + DO 820 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 810 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 810 CONTINUE +C + IC = IC + MB + 820 CONTINUE +C + JC = JC + 1 + 830 CONTINUE +C + 840 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 880 J = 1, NA +C + DO 870 K = 1, NB + IC = 1 +C + DO 860 I = 1, MA + AIJ = A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 850 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 850 CONTINUE +C + END IF + IC = IC + MB + 860 CONTINUE +C + JC = JC + 1 + 870 CONTINUE +C + 880 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 920 J = 1, NA +C + DO 910 K = 1, NB + IC = 1 +C + DO 900 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 890 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 890 CONTINUE +C + IC = IC + MB + 900 CONTINUE +C + JC = JC + 1 + 910 CONTINUE +C + 920 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 960 J = 1, NA +C + DO 950 K = 1, NB + IC = 1 +C + DO 940 I = 1, MA + AIJ = ALPHA*A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 930 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 930 CONTINUE +C + END IF + IC = IC + MB + 940 CONTINUE +C + JC = JC + 1 + 950 CONTINUE +C + 960 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 1000 J = 1, NA +C + DO 990 K = 1, NB + IC = 1 +C + DO 980 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 970 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(L,K) + LC = LC + 1 + 970 CONTINUE +C + IC = IC + MB + 980 CONTINUE +C + JC = JC + 1 + 990 CONTINUE +C + 1000 CONTINUE +C + END IF + END IF + END IF + ELSE IF ( TRANSB .AND. .NOT.TRANSA ) THEN +C +C Case op(A) = A and op(B) = B'. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 1080 J = 1, NA +C + DO 1070 K = 1, NB + IC = 1 +C + DO 1060 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1050 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1050 CONTINUE +C + END IF + IC = IC + MB + 1060 CONTINUE +C + JC = JC + 1 + 1070 CONTINUE +C + 1080 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 1120 J = 1, NA +C + DO 1110 K = 1, NB + IC = 1 +C + DO 1100 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1090 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1090 CONTINUE +C + IC = IC + MB + 1100 CONTINUE +C + JC = JC + 1 + 1110 CONTINUE +C + 1120 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 1160 J = 1, NA +C + DO 1150 K = 1, NB + IC = 1 +C + DO 1140 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1130 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1130 CONTINUE +C + END IF + IC = IC + MB + 1140 CONTINUE +C + JC = JC + 1 + 1150 CONTINUE +C + 1160 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 1200 J = 1, NA +C + DO 1190 K = 1, NB + IC = 1 +C + DO 1180 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1170 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1170 CONTINUE +C + IC = IC + MB + 1180 CONTINUE +C + JC = JC + 1 + 1190 CONTINUE +C + 1200 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 1240 J = 1, NA +C + DO 1230 K = 1, NB + IC = 1 +C + DO 1220 I = 1, MA + AIJ = A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1210 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1210 CONTINUE +C + END IF + IC = IC + MB + 1220 CONTINUE +C + JC = JC + 1 + 1230 CONTINUE +C + 1240 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 1280 J = 1, NA +C + DO 1270 K = 1, NB + IC = 1 +C + DO 1260 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1250 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1250 CONTINUE +C + IC = IC + MB + 1260 CONTINUE +C + JC = JC + 1 + 1270 CONTINUE +C + 1280 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 1320 J = 1, NA +C + DO 1310 K = 1, NB + IC = 1 +C + DO 1300 I = 1, MA + AIJ = ALPHA*A(I,J) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1290 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1290 CONTINUE +C + END IF + IC = IC + MB + 1300 CONTINUE +C + JC = JC + 1 + 1310 CONTINUE +C + 1320 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 1360 J = 1, NA +C + DO 1350 K = 1, NB + IC = 1 +C + DO 1340 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1330 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1330 CONTINUE +C + IC = IC + MB + 1340 CONTINUE +C + JC = JC + 1 + 1350 CONTINUE +C + 1360 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 1400 J = 1, NA +C + DO 1390 K = 1, NB + IC = 1 +C + DO 1380 I = 1, MA + AIJ = A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1370 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1370 CONTINUE +C + END IF + IC = IC + MB + 1380 CONTINUE +C + JC = JC + 1 + 1390 CONTINUE +C + 1400 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 1440 J = 1, NA +C + DO 1430 K = 1, NB + IC = 1 +C + DO 1420 I = 1, MA + AIJ = A(I,J) + LC = IC +C + DO 1410 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1410 CONTINUE +C + IC = IC + MB + 1420 CONTINUE +C + JC = JC + 1 + 1430 CONTINUE +C + 1440 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 1480 J = 1, NA +C + DO 1470 K = 1, NB + IC = 1 +C + DO 1460 I = 1, MA + AIJ = ALPHA*A(I,J) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1450 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1450 CONTINUE +C + END IF + IC = IC + MB + 1460 CONTINUE +C + JC = JC + 1 + 1470 CONTINUE +C + 1480 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 1520 J = 1, NA +C + DO 1510 K = 1, NB + IC = 1 +C + DO 1500 I = 1, MA + AIJ = ALPHA*A(I,J) + LC = IC +C + DO 1490 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1490 CONTINUE +C + IC = IC + MB + 1500 CONTINUE +C + JC = JC + 1 + 1510 CONTINUE +C + 1520 CONTINUE +C + END IF + END IF + END IF + ELSE +C +C Case op(A) = A' and op(B) = B'. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha = 1, A sparse. +C + DO 1580 J = 1, NA +C + DO 1570 K = 1, NB + IC = 1 +C + DO 1560 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE IF ( AIJ.EQ.ONE ) THEN + CALL DCOPY( MB, B(K,1), LDB, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1550 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1550 CONTINUE +C + END IF + IC = IC + MB + 1560 CONTINUE +C + JC = JC + 1 + 1570 CONTINUE +C + 1580 CONTINUE +C + ELSE +C +C Case beta = 0, alpha = 1, A not sparse. +C + DO 1620 J = 1, NA +C + DO 1610 K = 1, NB + IC = 1 +C + DO 1600 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1590 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1590 CONTINUE +C + IC = IC + MB + 1600 CONTINUE +C + JC = JC + 1 + 1610 CONTINUE +C + 1620 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 0, alpha <> 1, A sparse. +C + DO 1660 J = 1, NA +C + DO 1650 K = 1, NB + IC = 1 +C + DO 1640 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.EQ.ZERO ) THEN + CALL DCOPY( MB, DUM(1), 0, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1630 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1630 CONTINUE +C + END IF + IC = IC + MB + 1640 CONTINUE +C + JC = JC + 1 + 1650 CONTINUE +C + 1660 CONTINUE +C + ELSE +C +C Case beta = 0, alpha <> 1, A not sparse. +C + DO 1700 J = 1, NA +C + DO 1690 K = 1, NB + IC = 1 +C + DO 1680 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1670 L = 1, MB + C(LC,JC) = AIJ*B(K,L) + LC = LC + 1 + 1670 CONTINUE +C + IC = IC + MB + 1680 CONTINUE +C + JC = JC + 1 + 1690 CONTINUE +C + 1700 CONTINUE +C + END IF + END IF + ELSE IF ( BETA.EQ.ONE ) THEN + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha = 1, A sparse. +C + DO 1740 J = 1, NA +C + DO 1730 K = 1, NB + IC = 1 +C + DO 1720 I = 1, MA + AIJ = A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1710 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1710 CONTINUE +C + END IF + IC = IC + MB + 1720 CONTINUE +C + JC = JC + 1 + 1730 CONTINUE +C + 1740 CONTINUE +C + ELSE +C +C Case beta = 1, alpha = 1, A not sparse. +C + DO 1780 J = 1, NA +C + DO 1770 K = 1, NB + IC = 1 +C + DO 1760 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1750 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1750 CONTINUE +C + IC = IC + MB + 1760 CONTINUE +C + JC = JC + 1 + 1770 CONTINUE +C + 1780 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta = 1, alpha <> 1, A sparse. +C + DO 1820 J = 1, NA +C + DO 1810 K = 1, NB + IC = 1 +C + DO 1800 I = 1, MA + AIJ = ALPHA*A(J,I) + IF ( AIJ.NE.ZERO ) THEN + LC = IC +C + DO 1790 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1790 CONTINUE +C + END IF + IC = IC + MB + 1800 CONTINUE +C + JC = JC + 1 + 1810 CONTINUE +C + 1820 CONTINUE +C + ELSE +C +C Case beta = 1, alpha <> 1, A not sparse. +C + DO 1860 J = 1, NA +C + DO 1850 K = 1, NB + IC = 1 +C + DO 1840 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1830 L = 1, MB + C(LC,JC) = C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1830 CONTINUE +C + IC = IC + MB + 1840 CONTINUE +C + JC = JC + 1 + 1850 CONTINUE +C + 1860 CONTINUE +C + END IF + END IF + ELSE + IF ( ALPHA.EQ.ONE ) THEN + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha = 1, A sparse. +C + DO 1900 J = 1, NA +C + DO 1890 K = 1, NB + IC = 1 +C + DO 1880 I = 1, MA + AIJ = A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1870 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1870 CONTINUE +C + END IF + IC = IC + MB + 1880 CONTINUE +C + JC = JC + 1 + 1890 CONTINUE +C + 1900 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha = 1, A not sparse. +C + DO 1940 J = 1, NA +C + DO 1930 K = 1, NB + IC = 1 +C + DO 1920 I = 1, MA + AIJ = A(J,I) + LC = IC +C + DO 1910 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1910 CONTINUE +C + IC = IC + MB + 1920 CONTINUE +C + JC = JC + 1 + 1930 CONTINUE +C + 1940 CONTINUE +C + END IF + ELSE + IF ( SPARSE ) THEN +C +C Case beta <> 0 or 1, alpha <> 1, A sparse. +C + DO 1980 J = 1, NA +C + DO 1970 K = 1, NB + IC = 1 +C + DO 1960 I = 1, MA + AIJ = ALPHA*A(J,I) +C + IF ( AIJ.EQ.ZERO ) THEN + CALL DSCAL( MB, BETA, C(IC,JC), 1 ) + ELSE + LC = IC +C + DO 1950 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1950 CONTINUE +C + END IF + IC = IC + MB + 1960 CONTINUE +C + JC = JC + 1 + 1970 CONTINUE +C + 1980 CONTINUE +C + ELSE +C +C Case beta <> 0 or 1, alpha <> 1, A not sparse. +C + DO 2020 J = 1, NA +C + DO 2010 K = 1, NB + IC = 1 +C + DO 2000 I = 1, MA + AIJ = ALPHA*A(J,I) + LC = IC +C + DO 1990 L = 1, MB + C(LC,JC) = BETA*C(LC,JC) + AIJ*B(K,L) + LC = LC + 1 + 1990 CONTINUE +C + IC = IC + MB + 2000 CONTINUE +C + JC = JC + 1 + 2010 CONTINUE +C + 2020 CONTINUE +C + END IF + END IF + END IF + END IF + RETURN +C *** Last line of MB01VD *** + END diff --git a/mex/sources/libslicot/MB01WD.f b/mex/sources/libslicot/MB01WD.f new file mode 100644 index 000000000..53c85f9da --- /dev/null +++ b/mex/sources/libslicot/MB01WD.f @@ -0,0 +1,343 @@ + SUBROUTINE MB01WD( DICO, UPLO, TRANS, HESS, N, ALPHA, BETA, R, + $ LDR, A, LDA, T, LDT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix formula +C _ +C R = alpha*( op( A )'*op( T )'*op( T ) + op( T )'*op( T )*op( A ) ) +C + beta*R, (1) +C +C if DICO = 'C', or +C _ +C R = alpha*( op( A )'*op( T )'*op( T )*op( A ) - op( T )'*op( T )) +C + beta*R, (2) +C _ +C if DICO = 'D', where alpha and beta are scalars, R, and R are +C symmetric matrices, T is a triangular matrix, A is a general or +C Hessenberg matrix, and op( M ) is one of +C +C op( M ) = M or op( M ) = M'. +C +C The result is overwritten on R. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the formula to be evaluated, as follows: +C = 'C': formula (1), "continuous-time" case; +C = 'D': formula (2), "discrete-time" case. +C +C UPLO CHARACTER*1 +C Specifies which triangles of the symmetric matrix R and +C triangular matrix T are given, as follows: +C = 'U': the upper triangular parts of R and T are given; +C = 'L': the lower triangular parts of R and T are given; +C +C TRANS CHARACTER*1 +C Specifies the form of op( M ) to be used, as follows: +C = 'N': op( M ) = M; +C = 'T': op( M ) = M'; +C = 'C': op( M ) = M'. +C +C HESS CHARACTER*1 +C Specifies the form of the matrix A, as follows: +C = 'F': matrix A is full; +C = 'H': matrix A is Hessenberg (or Schur), either upper +C (if UPLO = 'U'), or lower (if UPLO = 'L'). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices R, A, and T. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then the arrays A +C and T are not referenced. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then the array R need +C not be set before entry. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry with UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix R. +C On entry with UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix R. +C On exit, the leading N-by-N upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C _ +C the computed matrix R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If HESS = 'H' the elements below the +C first subdiagonal, if UPLO = 'U', or above the first +C superdiagonal, if UPLO = 'L', need not be set to zero, +C and are not referenced if DICO = 'D'. +C On exit, the leading N-by-N part of this array contains +C the following matrix product +C alpha*T'*T*A, if TRANS = 'N', or +C alpha*A*T*T', otherwise, +C if DICO = 'C', or +C T*A, if TRANS = 'N', or +C A*T, otherwise, +C if DICO = 'D' (and in this case, these products have a +C Hessenberg form, if HESS = 'H'). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C T (input) DOUBLE PRECISION array, dimension (LDT,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular matrix T and +C the strictly lower triangular part need not be set to zero +C (and it is not referenced). +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular matrix T and +C the strictly upper triangular part need not be set to zero +C (and it is not referenced). +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -k, the k-th argument had an illegal +C value. +C +C METHOD +C +C The matrix expression (1) or (2) is efficiently evaluated taking +C the structure into account. BLAS 3 operations (DTRMM, DSYRK and +C their specializations) are used throughout. +C +C NUMERICAL ASPECTS +C +C If A is a full matrix, the algorithm requires approximately +C 3 +C N operations, if DICO = 'C'; +C 3 +C 7/6 x N operations, if DICO = 'D'. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, HESS, TRANS, UPLO + INTEGER INFO, LDA, LDR, LDT, N + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), R(LDR,*), T(LDT,*) +C .. Local Scalars .. + LOGICAL DISCR, REDUC, TRANSP, UPPER + CHARACTER NEGTRA, SIDE + INTEGER I, INFO2, J +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLASCL, DLASET, DSYRK, DTRMM, MB01YD, MB01ZD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + UPPER = LSAME( UPLO, 'U' ) + TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + REDUC = LSAME( HESS, 'H' ) +C + IF( .NOT.( DISCR .OR. LSAME( DICO, 'C' ) ) )THEN + INFO = -1 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) )THEN + INFO = -3 + ELSE IF( .NOT.( REDUC .OR. LSAME( HESS, 'F' ) ) )THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN + IF ( BETA.EQ.ZERO ) THEN +C +C Special case when both alpha = 0 and beta = 0. +C + CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR ) + ELSE +C +C Special case alpha = 0. +C + IF ( BETA.NE.ONE ) + $ CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, R, LDR, INFO2 ) + END IF + RETURN + END IF +C +C General case: alpha <> 0. +C +C Compute (in A) T*A, if TRANS = 'N', or +C A*T, otherwise. +C + IF ( TRANSP ) THEN + SIDE = 'R' + NEGTRA = 'N' + ELSE + SIDE = 'L' + NEGTRA = 'T' + END IF +C + IF ( REDUC .AND. N.GT.2 ) THEN + CALL MB01ZD( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, 1, + $ ONE, T, LDT, A, LDA, INFO2 ) + ELSE + CALL DTRMM( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, ONE, + $ T, LDT, A, LDA ) + END IF +C + IF( .NOT.DISCR ) THEN +C +C Compute (in A) alpha*T'*T*A, if TRANS = 'N', or +C alpha*A*T*T', otherwise. +C + IF ( REDUC .AND. N.GT.2 ) THEN + CALL MB01ZD( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, 1, + $ ALPHA, T, LDT, A, LDA, INFO2 ) + ELSE + CALL DTRMM( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, + $ ALPHA, T, LDT, A, LDA ) + END IF +C +C Compute the required triangle of the result, using symmetry. +C + IF ( UPPER ) THEN + IF ( BETA.EQ.ZERO ) THEN +C + DO 20 J = 1, N + DO 10 I = 1, J + R( I, J ) = A( I, J ) + A( J, I ) + 10 CONTINUE + 20 CONTINUE +C + ELSE +C + DO 40 J = 1, N + DO 30 I = 1, J + R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) + 30 CONTINUE + 40 CONTINUE +C + END IF +C + ELSE +C + IF ( BETA.EQ.ZERO ) THEN +C + DO 60 J = 1, N + DO 50 I = J, N + R( I, J ) = A( I, J ) + A( J, I ) + 50 CONTINUE + 60 CONTINUE +C + ELSE +C + DO 80 J = 1, N + DO 70 I = J, N + R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J ) + 70 CONTINUE + 80 CONTINUE +C + END IF +C + END IF +C + ELSE +C +C Compute (in R) alpha*A'*T'*T*A + beta*R, if TRANS = 'N', or +C alpha*A*T*T'*A' + beta*R, otherwise. +C + IF ( REDUC .AND. N.GT.2 ) THEN + CALL MB01YD( UPLO, NEGTRA, N, N, 1, ALPHA, BETA, A, LDA, R, + $ LDR, INFO2 ) + ELSE + CALL DSYRK( UPLO, NEGTRA, N, N, ALPHA, A, LDA, BETA, R, + $ LDR ) + END IF +C +C Compute (in R) -alpha*T'*T + R, if TRANS = 'N', or +C -alpha*T*T' + R, otherwise. +C + CALL MB01YD( UPLO, NEGTRA, N, N, 0, -ALPHA, ONE, T, LDT, R, + $ LDR, INFO2 ) +C + END IF +C + RETURN +C *** Last line of MB01WD *** + END diff --git a/mex/sources/libslicot/MB01XD.f b/mex/sources/libslicot/MB01XD.f new file mode 100644 index 000000000..3a54a2e2a --- /dev/null +++ b/mex/sources/libslicot/MB01XD.f @@ -0,0 +1,207 @@ + SUBROUTINE MB01XD( UPLO, N, A, LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product U' * U or L * L', where U and L are +C upper and lower triangular matrices, respectively, stored in the +C corresponding upper or lower triangular part of the array A. +C +C If UPLO = 'U' then the upper triangle of the result is stored, +C overwriting the matrix U in A. +C If UPLO = 'L' then the lower triangle of the result is stored, +C overwriting the matrix L in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which triangle (U or L) is given in the array A, +C as follows: +C = 'U': the upper triangular part U is given; +C = 'L': the lower triangular part L is given. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the triangular matrices U or L. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular matrix U. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular matrix L. +C On exit, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array contains the upper +C triangular part of the product U' * U. The strictly lower +C triangular part is not referenced. +C On exit, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array contains the lower +C triangular part of the product L * L'. The strictly upper +C triangular part is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix product U' * U or L * L' is computed using BLAS 3 +C operations as much as possible (a block algorithm). +C +C FURTHER COMMENTS +C +C This routine is a counterpart of LAPACK Library routine DLAUUM, +C which computes the matrix product U * U' or L' * L. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +C .. +C .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IB, II, NB +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DSYRK, DTRMM, MB01XY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01XD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Determine the block size for this environment (as for DLAUUM). +C + NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 ) +C + IF( NB.LE.1 .OR. NB.GE.N ) THEN +C +C Use unblocked code. +C + CALL MB01XY( UPLO, N, A, LDA, INFO ) + ELSE +C +C Use blocked code. +C + IF( UPPER ) THEN +C +C Compute the product U' * U. +C + DO 10 I = N, 1, -NB + IB = MIN( NB, I ) + II = I - IB + 1 + IF( I.LT.N ) THEN + CALL DTRMM( 'Left', 'Upper', 'Transpose', 'Non-unit', + $ IB, N-I, ONE, A( II, II ), LDA, + $ A( II, II+IB ), LDA ) + CALL DGEMM( 'Transpose', 'No transpose', IB, N-I, + $ I-IB, ONE, A( 1, II ), LDA, A( 1, II+IB ), + $ LDA, ONE, A( II, II+IB ), LDA ) + END IF + CALL MB01XY( 'Upper', IB, A( II, II ), LDA, INFO ) + CALL DSYRK( 'Upper', 'Transpose', IB, II-1, ONE, + $ A( 1, II ), LDA, ONE, A( II, II ), LDA ) + 10 CONTINUE + ELSE +C +C Compute the product L * L'. +C + DO 20 I = N, 1, -NB + IB = MIN( NB, I ) + II = I - IB + 1 + IF( I.LT.N ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Non-unit', + $ N-I, IB, ONE, A( II, II ), LDA, + $ A( II+IB, II ), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I, IB, + $ I-IB, ONE, A( II+IB, 1 ), LDA, A( II, 1 ), + $ LDA, ONE, A( II+IB, II ), LDA ) + END IF + CALL MB01XY( 'Lower', IB, A( II, II ), LDA, INFO ) + CALL DSYRK( 'Lower', 'No Transpose', IB, II-1, ONE, + $ A( II, 1 ), LDA, ONE, A( II, II ), LDA ) + 20 CONTINUE + END IF + END IF +C + RETURN +C +C *** Last line of MB01XD *** + END diff --git a/mex/sources/libslicot/MB01XY.f b/mex/sources/libslicot/MB01XY.f new file mode 100644 index 000000000..6af6275cd --- /dev/null +++ b/mex/sources/libslicot/MB01XY.f @@ -0,0 +1,191 @@ + SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product U' * U or L * L', where U and L are +C upper and lower triangular matrices, respectively, stored in the +C corresponding upper or lower triangular part of the array A. +C +C If UPLO = 'U' then the upper triangle of the result is stored, +C overwriting the matrix U in A. +C If UPLO = 'L' then the lower triangle of the result is stored, +C overwriting the matrix L in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which triangle (U or L) is given in the array A, +C as follows: +C = 'U': the upper triangular part U is given; +C = 'L': the lower triangular part L is given. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the triangular matrices U or L. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular matrix U. +C On entry, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular matrix L. +C On exit, if UPLO = 'U', the leading N-by-N upper +C triangular part of this array contains the upper +C triangular part of the product U' * U. The strictly lower +C triangular part is not referenced. +C On exit, if UPLO = 'L', the leading N-by-N lower +C triangular part of this array contains the lower +C triangular part of the product L * L'. The strictly upper +C triangular part is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix product U' * U or L * L' is computed using BLAS 2 and +C BLAS 1 operations (an unblocked algorithm). +C +C FURTHER COMMENTS +C +C This routine is a counterpart of LAPACK Library routine DLAUU2, +C which computes the matrix product U * U' or L' * L. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +C .. +C .. Local Scalars .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION AII +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGEMV, DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01XY', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + IF( UPPER ) THEN +C +C Compute the product U' * U. +C + A( N, N ) = DDOT( N, A( 1, N ), 1, A( 1, N ), 1 ) +C + DO 10 I = N-1, 2, -1 + AII = A( I, I ) + A( I, I ) = DDOT( I, A( 1, I ), 1, A( 1, I ), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), LDA, + $ A( 1, I ), 1, AII, A( I, I+1 ), LDA ) + 10 CONTINUE +C + IF( N.GT.1 ) THEN + AII = A( 1, 1 ) + CALL DSCAL( N, AII, A( 1, 1 ), LDA ) + END IF +C + ELSE +C +C Compute the product L * L'. +C + A( N, N ) = DDOT( N, A( N, 1 ), LDA, A( N, 1 ), LDA ) +C + DO 20 I = N-1, 2, -1 + AII = A( I, I ) + A( I, I ) = DDOT( I, A( I, 1 ), LDA, A( I, 1 ), LDA ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A( I+1, 1 ), + $ LDA, A( I, 1 ), LDA, AII, A( I+1, I ), 1 ) + 20 CONTINUE +C + IF( N.GT.1 ) THEN + AII = A( 1, 1 ) + CALL DSCAL( N, AII, A( 1, 1 ), 1 ) + END IF + END IF +C + RETURN +C +C *** Last line of MB01XY *** + END diff --git a/mex/sources/libslicot/MB01YD.f b/mex/sources/libslicot/MB01YD.f new file mode 100644 index 000000000..6d5c2a0fe --- /dev/null +++ b/mex/sources/libslicot/MB01YD.f @@ -0,0 +1,352 @@ + SUBROUTINE MB01YD( UPLO, TRANS, N, K, L, ALPHA, BETA, A, LDA, C, + $ LDC, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the symmetric rank k operations +C +C C := alpha*op( A )*op( A )' + beta*C, +C +C where alpha and beta are scalars, C is an n-by-n symmetric matrix, +C op( A ) is an n-by-k matrix, and op( A ) is one of +C +C op( A ) = A or op( A ) = A'. +C +C The matrix A has l nonzero codiagonals, either upper or lower. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Specifies which triangle of the symmetric matrix C +C is given and computed, as follows: +C = 'U': the upper triangular part is given/computed; +C = 'L': the lower triangular part is given/computed. +C UPLO also defines the pattern of the matrix A (see below). +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used, as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix C. N >= 0. +C +C K (input) INTEGER +C The number of columns of the matrix op( A ). K >= 0. +C +C L (input) INTEGER +C If UPLO = 'U', matrix A has L nonzero subdiagonals. +C If UPLO = 'L', matrix A has L nonzero superdiagonals. +C MAX(0,NR-1) >= L >= 0, if UPLO = 'U', +C MAX(0,NC-1) >= L >= 0, if UPLO = 'L', +C where NR and NC are the numbers of rows and columns of the +C matrix A, respectively. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then the array A is +C not referenced. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then the array C need +C not be set before entry. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,NC), where +C NC is K when TRANS = 'N', and is N otherwise. +C If TRANS = 'N', the leading N-by-K part of this array must +C contain the matrix A, otherwise the leading K-by-N part of +C this array must contain the matrix A. +C If UPLO = 'U', only the upper triangular part and the +C first L subdiagonals are referenced, and the remaining +C subdiagonals are assumed to be zero. +C If UPLO = 'L', only the lower triangular part and the +C first L superdiagonals are referenced, and the remaining +C superdiagonals are assumed to be zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,NR), +C where NR = N, if TRANS = 'N', and NR = K, otherwise. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the symmetric matrix C. +C On entry with UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the symmetric matrix C. +C On exit, the leading N-by-N upper triangular part (if +C UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of +C this array contains the corresponding triangular part of +C the updated matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The calculations are efficiently performed taking the symmetry +C and structure into account. +C +C FURTHER COMMENTS +C +C The matrix A may have the following patterns, when n = 7, k = 5, +C and l = 2 are used for illustration: +C +C UPLO = 'U', TRANS = 'N' UPLO = 'L', TRANS = 'N' +C +C [ x x x x x ] [ x x x 0 0 ] +C [ x x x x x ] [ x x x x 0 ] +C [ x x x x x ] [ x x x x x ] +C A = [ 0 x x x x ], A = [ x x x x x ], +C [ 0 0 x x x ] [ x x x x x ] +C [ 0 0 0 x x ] [ x x x x x ] +C [ 0 0 0 0 x ] [ x x x x x ] +C +C UPLO = 'U', TRANS = 'T' UPLO = 'L', TRANS = 'T' +C +C [ x x x x x x x ] [ x x x 0 0 0 0 ] +C [ x x x x x x x ] [ x x x x 0 0 0 ] +C A = [ x x x x x x x ], A = [ x x x x x 0 0 ]. +C [ 0 x x x x x x ] [ x x x x x x 0 ] +C [ 0 0 x x x x x ] [ x x x x x x x ] +C +C If N = K, the matrix A is upper or lower triangular, for L = 0, +C and upper or lower Hessenberg, for L = 1. +C +C This routine is a specialization of the BLAS 3 routine DSYRK. +C BLAS 1 calls are used when appropriate, instead of in-line code, +C in order to increase the efficiency. If the matrix A is full, or +C its zero triangle has small order, an optimized DSYRK code could +C be faster than MB01YD. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TRANS, UPLO + INTEGER INFO, LDA, LDC, K, L, N + DOUBLE PRECISION ALPHA, BETA +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ) +C .. +C .. Local Scalars .. + LOGICAL TRANSP, UPPER + INTEGER I, J, M, NCOLA, NROWA + DOUBLE PRECISION TEMP +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DLASCL, DLASET, DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + IF( TRANSP )THEN + NROWA = K + NCOLA = N + ELSE + NROWA = N + NCOLA = K + END IF +C + IF( UPPER )THEN + M = NROWA + ELSE + M = NCOLA + END IF +C + IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( K.LT.0 ) THEN + INFO = -4 + ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M-1 ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01YD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) THEN + IF ( BETA.EQ.ZERO ) THEN +C +C Special case when both alpha = 0 and beta = 0. +C + CALL DLASET( UPLO, N, N, ZERO, ZERO, C, LDC ) + ELSE +C +C Special case alpha = 0. +C + CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, C, LDC, INFO ) + END IF + RETURN + END IF +C +C General case: alpha <> 0. +C + IF ( .NOT.TRANSP ) THEN +C +C Form C := alpha*A*A' + beta*C. +C + IF ( UPPER ) THEN +C + DO 30 J = 1, N + IF ( BETA.EQ.ZERO ) THEN +C + DO 10 I = 1, J + C( I, J ) = ZERO + 10 CONTINUE +C + ELSE IF ( BETA.NE.ONE ) THEN + CALL DSCAL ( J, BETA, C( 1, J ), 1 ) + END IF +C + DO 20 M = MAX( 1, J-L ), K + CALL DAXPY ( MIN( J, L+M ), ALPHA*A( J, M ), + $ A( 1, M ), 1, C( 1, J ), 1 ) + 20 CONTINUE +C + 30 CONTINUE +C + ELSE +C + DO 60 J = 1, N + IF ( BETA.EQ.ZERO ) THEN +C + DO 40 I = J, N + C( I, J ) = ZERO + 40 CONTINUE +C + ELSE IF ( BETA.NE.ONE ) THEN + CALL DSCAL ( N-J+1, BETA, C( J, J ), 1 ) + END IF +C + DO 50 M = 1, MIN( J+L, K ) + CALL DAXPY ( N-J+1, ALPHA*A( J, M ), A( J, M ), 1, + $ C( J, J ), 1 ) + 50 CONTINUE +C + 60 CONTINUE +C + END IF +C + ELSE +C +C Form C := alpha*A'*A + beta*C. +C + IF ( UPPER ) THEN +C + DO 80 J = 1, N +C + DO 70 I = 1, J + TEMP = ALPHA*DDOT ( MIN( J+L, K ), A( 1, I ), 1, + $ A( 1, J ), 1 ) + IF ( BETA.EQ.ZERO ) THEN + C( I, J ) = TEMP + ELSE + C( I, J ) = TEMP + BETA*C( I, J ) + END IF + 70 CONTINUE +C + 80 CONTINUE +C + ELSE +C + DO 100 J = 1, N +C + DO 90 I = J, N + M = MAX( 1, I-L ) + TEMP = ALPHA*DDOT ( K-M+1, A( M, I ), 1, A( M, J ), + $ 1 ) + IF ( BETA.EQ.ZERO ) THEN + C( I, J ) = TEMP + ELSE + C( I, J ) = TEMP + BETA*C( I, J ) + END IF + 90 CONTINUE +C + 100 CONTINUE +C + END IF +C + END IF +C + RETURN +C +C *** Last line of MB01YD *** + END diff --git a/mex/sources/libslicot/MB01ZD.f b/mex/sources/libslicot/MB01ZD.f new file mode 100644 index 000000000..abdbbf473 --- /dev/null +++ b/mex/sources/libslicot/MB01ZD.f @@ -0,0 +1,475 @@ + SUBROUTINE MB01ZD( SIDE, UPLO, TRANST, DIAG, M, N, L, ALPHA, T, + $ LDT, H, LDH, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product +C +C H := alpha*op( T )*H, or H := alpha*H*op( T ), +C +C where alpha is a scalar, H is an m-by-n upper or lower +C Hessenberg-like matrix (with l nonzero subdiagonals or +C superdiagonals, respectively), T is a unit, or non-unit, +C upper or lower triangular matrix, and op( T ) is one of +C +C op( T ) = T or op( T ) = T'. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether the triangular matrix T appears on the +C left or right in the matrix product, as follows: +C = 'L': the product alpha*op( T )*H is computed; +C = 'R': the product alpha*H*op( T ) is computed. +C +C UPLO CHARACTER*1 +C Specifies the form of the matrices T and H, as follows: +C = 'U': the matrix T is upper triangular and the matrix H +C is upper Hessenberg-like; +C = 'L': the matrix T is lower triangular and the matrix H +C is lower Hessenberg-like. +C +C TRANST CHARACTER*1 +C Specifies the form of op( T ) to be used, as follows: +C = 'N': op( T ) = T; +C = 'T': op( T ) = T'; +C = 'C': op( T ) = T'. +C +C DIAG CHARACTER*1. +C Specifies whether or not T is unit triangular, as follows: +C = 'U': the matrix T is assumed to be unit triangular; +C = 'N': the matrix T is not assumed to be unit triangular. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of H. M >= 0. +C +C N (input) INTEGER +C The number of columns of H. N >= 0. +C +C L (input) INTEGER +C If UPLO = 'U', matrix H has L nonzero subdiagonals. +C If UPLO = 'L', matrix H has L nonzero superdiagonals. +C MAX(0,M-1) >= L >= 0, if UPLO = 'U'; +C MAX(0,N-1) >= L >= 0, if UPLO = 'L'. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then T is not +C referenced and H need not be set before entry. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,k), where +C k is m when SIDE = 'L' and is n when SIDE = 'R'. +C If UPLO = 'U', the leading k-by-k upper triangular part +C of this array must contain the upper triangular matrix T +C and the strictly lower triangular part is not referenced. +C If UPLO = 'L', the leading k-by-k lower triangular part +C of this array must contain the lower triangular matrix T +C and the strictly upper triangular part is not referenced. +C Note that when DIAG = 'U', the diagonal elements of T are +C not referenced either, but are assumed to be unity. +C +C LDT INTEGER +C The leading dimension of array T. +C LDT >= MAX(1,M), if SIDE = 'L'; +C LDT >= MAX(1,N), if SIDE = 'R'. +C +C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) +C On entry, if UPLO = 'U', the leading M-by-N upper +C Hessenberg part of this array must contain the upper +C Hessenberg-like matrix H. +C On entry, if UPLO = 'L', the leading M-by-N lower +C Hessenberg part of this array must contain the lower +C Hessenberg-like matrix H. +C On exit, the leading M-by-N part of this array contains +C the matrix product alpha*op( T )*H, if SIDE = 'L', +C or alpha*H*op( T ), if SIDE = 'R'. If TRANST = 'N', this +C product has the same pattern as the given matrix H; +C the elements below the L-th subdiagonal (if UPLO = 'U'), +C or above the L-th superdiagonal (if UPLO = 'L'), are not +C referenced in this case. If TRANST = 'T', the elements +C below the (N+L)-th row (if UPLO = 'U', SIDE = 'R', and +C M > N+L), or at the right of the (M+L)-th column +C (if UPLO = 'L', SIDE = 'L', and N > M+L), are not set to +C zero nor referenced. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= max(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The calculations are efficiently performed taking the problem +C structure into account. +C +C FURTHER COMMENTS +C +C The matrix H may have the following patterns, when m = 7, n = 6, +C and l = 2 are used for illustration: +C +C UPLO = 'U' UPLO = 'L' +C +C [ x x x x x x ] [ x x x 0 0 0 ] +C [ x x x x x x ] [ x x x x 0 0 ] +C [ x x x x x x ] [ x x x x x 0 ] +C H = [ 0 x x x x x ], H = [ x x x x x x ]. +C [ 0 0 x x x x ] [ x x x x x x ] +C [ 0 0 0 x x x ] [ x x x x x x ] +C [ 0 0 0 0 x x ] [ x x x x x x ] +C +C The products T*H or H*T have the same pattern as H, but the +C products T'*H or H*T' may be full matrices. +C +C If m = n, the matrix H is upper or lower triangular, for l = 0, +C and upper or lower Hessenberg, for l = 1. +C +C This routine is a specialization of the BLAS 3 routine DTRMM. +C BLAS 1 calls are used when appropriate, instead of in-line code, +C in order to increase the efficiency. If the matrix H is full, or +C its zero triangle has small order, an optimized DTRMM code could +C be faster than MB01ZD. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER DIAG, SIDE, TRANST, UPLO + INTEGER INFO, L, LDH, LDT, M, N + DOUBLE PRECISION ALPHA +C .. +C .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), T( LDT, * ) +C .. +C .. Local Scalars .. + LOGICAL LSIDE, NOUNIT, TRANS, UPPER + INTEGER I, I1, I2, J, K, M2, NROWT + DOUBLE PRECISION TEMP +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL DDOT, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + LSIDE = LSAME( SIDE, 'L' ) + UPPER = LSAME( UPLO, 'U' ) + TRANS = LSAME( TRANST, 'T' ) .OR. LSAME( TRANST, 'C' ) + NOUNIT = LSAME( DIAG, 'N' ) + IF( LSIDE )THEN + NROWT = M + ELSE + NROWT = N + END IF +C + IF( UPPER )THEN + M2 = M + ELSE + M2 = N + END IF +C + INFO = 0 + IF( .NOT.( LSIDE .OR. LSAME( SIDE, 'R' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( TRANS .OR. LSAME( TRANST, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( NOUNIT .OR. LSAME( DIAG, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( L.LT.0 .OR. L.GT.MAX( 0, M2-1 ) ) THEN + INFO = -7 + ELSE IF( LDT.LT.MAX( 1, NROWT ) ) THEN + INFO = -10 + ELSE IF( LDH.LT.MAX( 1, M ) )THEN + INFO = -12 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB01ZD', -INFO ) + RETURN + END IF +C +C Quick return, if possible. +C + IF( MIN( M, N ).EQ.0 ) + $ RETURN +C +C Also, when alpha = 0. +C + IF( ALPHA.EQ.ZERO ) THEN +C + DO 20, J = 1, N + IF( UPPER ) THEN + I1 = 1 + I2 = MIN( J+L, M ) + ELSE + I1 = MAX( 1, J-L ) + I2 = M + END IF +C + DO 10, I = I1, I2 + H( I, J ) = ZERO + 10 CONTINUE +C + 20 CONTINUE +C + RETURN + END IF +C +C Start the operations. +C + IF( LSIDE )THEN + IF( .NOT.TRANS ) THEN +C +C Form H := alpha*T*H. +C + IF( UPPER ) THEN +C + DO 40, J = 1, N +C + DO 30, K = 1, MIN( J+L, M ) + IF( H( K, J ).NE.ZERO ) THEN + TEMP = ALPHA*H( K, J ) + CALL DAXPY ( K-1, TEMP, T( 1, K ), 1, H( 1, J ), + $ 1 ) + IF( NOUNIT ) + $ TEMP = TEMP*T( K, K ) + H( K, J ) = TEMP + END IF + 30 CONTINUE +C + 40 CONTINUE +C + ELSE +C + DO 60, J = 1, N +C + DO 50 K = M, MAX( 1, J-L ), -1 + IF( H( K, J ).NE.ZERO ) THEN + TEMP = ALPHA*H( K, J ) + H( K, J ) = TEMP + IF( NOUNIT ) + $ H( K, J ) = H( K, J )*T( K, K ) + CALL DAXPY ( M-K, TEMP, T( K+1, K ), 1, + $ H( K+1, J ), 1 ) + END IF + 50 CONTINUE +C + 60 CONTINUE +C + END IF +C + ELSE +C +C Form H := alpha*T'*H. +C + IF( UPPER ) THEN +C + DO 80, J = 1, N + I1 = J + L +C + DO 70, I = M, 1, -1 + IF( I.GT.I1 ) THEN + TEMP = DDOT( I1, T( 1, I ), 1, H( 1, J ), 1 ) + ELSE + TEMP = H( I, J ) + IF( NOUNIT ) + $ TEMP = TEMP*T( I, I ) + TEMP = TEMP + DDOT( I-1, T( 1, I ), 1, + $ H( 1, J ), 1 ) + END IF + H( I, J ) = ALPHA*TEMP + 70 CONTINUE +C + 80 CONTINUE +C + ELSE +C + DO 100, J = 1, MIN( M+L, N ) + I1 = J - L +C + DO 90, I = 1, M + IF( I.LT.I1 ) THEN + TEMP = DDOT( M-I1+1, T( I1, I ), 1, H( I1, J ), + $ 1 ) + ELSE + TEMP = H( I, J ) + IF( NOUNIT ) + $ TEMP = TEMP*T( I, I ) + TEMP = TEMP + DDOT( M-I, T( I+1, I ), 1, + $ H( I+1, J ), 1 ) + END IF + H( I, J ) = ALPHA*TEMP + 90 CONTINUE +C + 100 CONTINUE +C + END IF +C + END IF +C + ELSE +C + IF( .NOT.TRANS ) THEN +C +C Form H := alpha*H*T. +C + IF( UPPER ) THEN +C + DO 120, J = N, 1, -1 + I2 = MIN( J+L, M ) + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*T( J, J ) + CALL DSCAL ( I2, TEMP, H( 1, J ), 1 ) +C + DO 110, K = 1, J - 1 + CALL DAXPY ( I2, ALPHA*T( K, J ), H( 1, K ), 1, + $ H( 1, J ), 1 ) + 110 CONTINUE +C + 120 CONTINUE +C + ELSE +C + DO 140, J = 1, N + I1 = MAX( 1, J-L ) + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*T( J, J ) + CALL DSCAL ( M-I1+1, TEMP, H( I1, J ), 1 ) +C + DO 130, K = J + 1, N + CALL DAXPY ( M-I1+1, ALPHA*T( K, J ), H( I1, K ), + $ 1, H( I1, J ), 1 ) + 130 CONTINUE +C + 140 CONTINUE +C + END IF +C + ELSE +C +C Form H := alpha*H*T'. +C + IF( UPPER ) THEN + M2 = MIN( N+L, M ) +C + DO 170, K = 1, N + I1 = MIN( K+L, M ) + I2 = MIN( K+L, M2 ) +C + DO 160, J = 1, K - 1 + IF( T( J, K ).NE.ZERO ) THEN + TEMP = ALPHA*T( J, K ) + CALL DAXPY ( I1, TEMP, H( 1, K ), 1, H( 1, J ), + $ 1 ) +C + DO 150, I = I1 + 1, I2 + H( I, J ) = TEMP*H( I, K ) + 150 CONTINUE +C + END IF + 160 CONTINUE +C + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*T( K, K ) + IF( TEMP.NE.ONE ) + $ CALL DSCAL( I2, TEMP, H( 1, K ), 1 ) + 170 CONTINUE +C + ELSE +C + DO 200, K = N, 1, -1 + I1 = MAX( 1, K-L ) + I2 = MAX( 1, K-L+1 ) + M2 = MIN( M, I2-1 ) +C + DO 190, J = K + 1, N + IF( T( J, K ).NE.ZERO ) THEN + TEMP = ALPHA*T( J, K ) + CALL DAXPY ( M-I2+1, TEMP, H( I2, K ), 1, + $ H( I2, J ), 1 ) +C + DO 180, I = I1, M2 + H( I, J ) = TEMP*H( I, K ) + 180 CONTINUE +C + END IF + 190 CONTINUE +C + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*T( K, K ) + IF( TEMP.NE.ONE ) + $ CALL DSCAL( M-I1+1, TEMP, H( I1, K ), 1 ) + 200 CONTINUE +C + END IF +C + END IF +C + END IF +C + RETURN +C +C *** Last line of MB01ZD *** + END diff --git a/mex/sources/libslicot/MB02CD.f b/mex/sources/libslicot/MB02CD.f new file mode 100644 index 000000000..2c878db9d --- /dev/null +++ b/mex/sources/libslicot/MB02CD.f @@ -0,0 +1,597 @@ + SUBROUTINE MB02CD( JOB, TYPET, K, N, T, LDT, G, LDG, R, LDR, L, + $ LDL, CS, LCS, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor and the generator and/or the +C Cholesky factor of the inverse of a symmetric positive definite +C (s.p.d.) block Toeplitz matrix T, defined by either its first +C block row, or its first block column, depending on the routine +C parameter TYPET. Transformation information is stored. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the output of the routine, as follows: +C = 'G': only computes the generator G of the inverse; +C = 'R': computes the generator G of the inverse and the +C Cholesky factor R of T, i.e., if TYPET = 'R', +C then R'*R = T, and if TYPET = 'C', then R*R' = T; +C = 'L': computes the generator G and the Cholesky factor L +C of the inverse, i.e., if TYPET = 'R', then +C L'*L = inv(T), and if TYPET = 'C', then +C L*L' = inv(T); +C = 'A': computes the generator G, the Cholesky factor L +C of the inverse and the Cholesky factor R of T; +C = 'O': only computes the Cholesky factor R of T. +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': T contains the first block row of an s.p.d. block +C Toeplitz matrix; if demanded, the Cholesky factors +C R and L are upper and lower triangular, +C respectively, and G contains the transposed +C generator of the inverse; +C = 'C': T contains the first block column of an s.p.d. +C block Toeplitz matrix; if demanded, the Cholesky +C factors R and L are lower and upper triangular, +C respectively, and G contains the generator of the +C inverse. This choice results in a column oriented +C algorithm which is usually faster. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 0. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N*K) / (LDT,K) +C On entry, the leading K-by-N*K / N*K-by-K part of this +C array must contain the first block row / column of an +C s.p.d. block Toeplitz matrix. +C On exit, if INFO = 0, then the leading K-by-N*K / N*K-by-K +C part of this array contains, in the first K-by-K block, +C the upper / lower Cholesky factor of T(1:K,1:K), and in +C the remaining part, the Householder transformations +C applied during the process. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K), if TYPET = 'R'; +C LDT >= MAX(1,N*K), if TYPET = 'C'. +C +C G (output) DOUBLE PRECISION array, dimension +C (LDG,N*K) / (LDG,2*K) +C If INFO = 0 and JOB = 'G', 'R', 'L', or 'A', the leading +C 2*K-by-N*K / N*K-by-2*K part of this array contains, in +C the first K-by-K block of the second block row / column, +C the lower right block of L (necessary for updating +C factorizations in SLICOT Library routine MB02DD), and +C in the remaining part, the generator of the inverse of T. +C Actually, to obtain a generator one has to set +C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; +C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. +C +C LDG INTEGER +C The leading dimension of the array G. +C LDG >= MAX(1,2*K), if TYPET = 'R' and +C JOB = 'G', 'R', 'L', or 'A'; +C LDG >= MAX(1,N*K), if TYPET = 'C' and +C JOB = 'G', 'R', 'L', or 'A'; +C LDG >= 1, if JOB = 'O'. +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N*K) +C If INFO = 0 and JOB = 'R', 'A', or 'O', then the leading +C N*K-by-N*K part of this array contains the upper / lower +C Cholesky factor of T. +C The elements in the strictly lower / upper triangular part +C are not referenced. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX(1,N*K), if JOB = 'R', 'A', or 'O'; +C LDR >= 1, if JOB = 'G', or 'L'. +C +C L (output) DOUBLE PRECISION array, dimension (LDL,N*K) +C If INFO = 0 and JOB = 'L', or 'A', then the leading +C N*K-by-N*K part of this array contains the lower / upper +C Cholesky factor of the inverse of T. +C The elements in the strictly upper / lower triangular part +C are not referenced. +C +C LDL INTEGER +C The leading dimension of the array L. +C LDL >= MAX(1,N*K), if JOB = 'L', or 'A'; +C LDL >= 1, if JOB = 'G', 'R', or 'O'. +C +C CS (output) DOUBLE PRECISION array, dimension (LCS) +C If INFO = 0, then the leading 3*(N-1)*K part of this +C array contains information about the hyperbolic rotations +C and Householder transformations applied during the +C process. This information is needed for updating the +C factorizations in SLICOT Library routine MB02DD. +C +C LCS INTEGER +C The length of the array CS. LCS >= 3*(N-1)*K. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,(N-1)*K). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The Toeplitz matrix +C associated with T is not (numerically) positive +C definite. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 2 +C The algorithm requires 0(K N ) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2000, +C February 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB, TYPET + INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), + $ T(LDT,*) +C .. Local Scalars .. + INTEGER I, IERR, MAXWRK, STARTI, STARTR, STARTT + LOGICAL COMPG, COMPL, COMPR, ISROW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, DPOTRF, DTRSM, MB02CX, MB02CY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COMPL = LSAME( JOB, 'L' ) .OR. LSAME( JOB, 'A' ) + COMPG = LSAME( JOB, 'G' ) .OR. LSAME( JOB, 'R' ) .OR. COMPL + COMPR = LSAME( JOB, 'R' ) .OR. LSAME( JOB, 'A' ) .OR. + $ LSAME( JOB, 'O' ) + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPG .OR. COMPR ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN + INFO = -6 + ELSE IF ( LDG.LT.1 .OR. + $ ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) + $ .OR. ( .NOT.ISROW .AND. LDG.LT.N*K ) ) ) ) THEN + INFO = -8 + ELSE IF ( LDR.LT.1 .OR. ( COMPR .AND. ( LDR.LT.N*K ) ) ) THEN + INFO = -10 + ELSE IF ( LDL.LT.1 .OR. ( COMPL .AND. ( LDL.LT.N*K ) ) ) THEN + INFO = -12 + ELSE IF ( LCS.LT.3*( N - 1 )*K ) THEN + INFO = -14 + ELSE IF ( LDWORK.LT.MAX( 1, ( N - 1 )*K ) ) THEN + DWORK(1) = MAX( 1, ( N - 1 )*K ) + INFO = -16 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + MAXWRK = 1 + IF ( ISROW ) THEN +C +C T is the first block row of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Upper', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, + $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) +C +C Initialize the output matrices. +C + IF ( COMPG ) THEN + CALL DLASET( 'All', 2*K, N*K, ZERO, ZERO, G, LDG ) + CALL DLASET( 'All', 1, K, ONE, ONE, G(K+1,1), LDG+1 ) + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, + $ ONE, T, LDT, G(K+1,1), LDG ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, G(K+1,K+1), + $ LDG ) + CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, G, LDG ) + END IF +C + IF ( COMPL ) THEN + CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, L, LDL ) + END IF +C + IF ( COMPR ) THEN + CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) + END IF +C +C Processing the generator. +C + IF ( COMPG ) THEN +C +C Here we use G as working array for holding the generator. +C T contains the second row of the generator. +C G contains in its first block row the second row of the +C inverse generator. +C The second block row of G is partitioned as follows: +C +C [ First block of the inverse generator, ... +C First row of the generator, ... +C The rest of the blocks of the inverse generator ] +C +C The reason for the odd partitioning is that the first block +C of the inverse generator will be thrown out at the end and +C we want to avoid reordering. +C +C (N-1)*K locations of DWORK are used by SLICOT Library +C routine MB02CY. +C + DO 10 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTI = ( N - I + 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 +C +C Transformations acting on the generator: +C + CALL MB02CX( 'Row', K, K, K, G(K+1,K+1), LDG, + $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( N.GT.I ) THEN + CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, + $ G(K+1,2*K+1), LDG, T(1,STARTR+K), LDT, + $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + IF ( COMPR ) THEN + CALL DLACPY( 'Upper', K, (N-I+1)*K, G(K+1,K+1), LDG, + $ R(STARTR,STARTR), LDR) + END IF +C +C Transformations acting on the inverse generator: +C + CALL DLASET( 'All', K, K, ZERO, ZERO, G(K+1,STARTI), + $ LDG ) + CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), + $ LDG, G(1,STARTR), LDG, T(1,STARTR), LDT, + $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, + $ G(K+1,STARTI), LDG, G, LDG, T(1,STARTR), + $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + IF ( COMPL ) THEN + CALL DLACPY( 'All', K, (I-1)*K, G(K+1,STARTI), LDG, + $ L(STARTR,1), LDL ) + CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, + $ L(STARTR,(I-1)*K+1), LDL ) + END IF + 10 CONTINUE +C + ELSE +C +C Here R is used as working array for holding the generator. +C Again, T contains the second row of the generator. +C The current row of R contains the first row of the +C generator. +C + IF ( N.GT.1 ) + $ CALL DLACPY( 'Upper', K, (N-1)*K, T, LDT, R(K+1,K+1), + $ LDR ) +C + DO 20 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 + CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, + $ T(1,STARTR), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( N.GT.I ) THEN + CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, + $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), + $ LDT, T(1,STARTR), LDT, CS(STARTT), 3*K, + $ DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL DLACPY( 'Upper', K, (N-I)*K, R(STARTR,STARTR), + $ LDR, R(STARTR+K,STARTR+K), LDR ) + END IF + 20 CONTINUE +C + END IF +C + ELSE +C +C T is the first block column of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Lower', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', + $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) +C +C Initialize the output matrices. +C + IF ( COMPG ) THEN + CALL DLASET( 'All', N*K, 2*K, ZERO, ZERO, G, LDG ) + CALL DLASET( 'All', 1, K, ONE, ONE, G(1,K+1), LDG+1 ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, + $ ONE, T, LDT, G(1,K+1), LDG ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, G(K+1,K+1), + $ LDG ) + CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, G, LDG ) + END IF +C + IF ( COMPL ) THEN + CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, L, LDL ) + END IF +C + IF ( COMPR ) THEN + CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) + END IF +C +C Processing the generator. +C + IF ( COMPG ) THEN +C +C Here we use G as working array for holding the generator. +C T contains the second column of the generator. +C G contains in its first block column the second column of +C the inverse generator. +C The second block column of G is partitioned as follows: +C +C [ First block of the inverse generator; ... +C First column of the generator; ... +C The rest of the blocks of the inverse generator ] +C +C The reason for the odd partitioning is that the first block +C of the inverse generator will be thrown out at the end and +C we want to avoid reordering. +C +C (N-1)*K locations of DWORK are used by SLICOT Library +C routine MB02CY. +C + DO 30 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTI = ( N - I + 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 +C +C Transformations acting on the generator: +C + CALL MB02CX( 'Column', K, K, K, G(K+1,K+1), LDG, + $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( N.GT.I ) THEN + CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, + $ K, G(2*K+1,K+1), LDG, T(STARTR+K,1), LDT, + $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + IF ( COMPR ) THEN + CALL DLACPY( 'Lower', (N-I+1)*K, K, G(K+1,K+1), LDG, + $ R(STARTR,STARTR), LDR) + END IF +C +C Transformations acting on the inverse generator: +C + CALL DLASET( 'All', K, K, ZERO, ZERO, G(STARTI,K+1), + $ LDG ) + CALL MB02CY( 'Column', 'Triangular', K, K, K, K, + $ G(1,K+1), LDG, G(STARTR,1), LDG, + $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, + $ G(STARTI,K+1), LDG, G, LDG, T(STARTR,1), + $ LDT, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + IF ( COMPL ) THEN + CALL DLACPY( 'All', (I-1)*K, K, G(STARTI,K+1), LDG, + $ L(1,STARTR), LDL ) + CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, + $ L((I-1)*K+1,STARTR), LDL ) + END IF + 30 CONTINUE +C + ELSE +C +C Here R is used as working array for holding the generator. +C Again, T contains the second column of the generator. +C The current column of R contains the first column of the +C generator. +C + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', (N-1)*K, K, T, LDT, R(K+1,K+1), + $ LDR ) +C + DO 40 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 + CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, + $ T(STARTR,1), LDT, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( N.GT.I ) THEN + CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, + $ K, R(STARTR+K,STARTR), LDR, + $ T(STARTR+K,1), LDT, T(STARTR,1), LDT, + $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL DLACPY( 'Lower', (N-I)*K, K, R(STARTR,STARTR), + $ LDR, R(STARTR+K,STARTR+K), LDR ) + END IF + 40 CONTINUE +C + END IF + END IF +C + DWORK(1) = MAXWRK +C + RETURN +C +C *** Last line of MB02CD *** + END diff --git a/mex/sources/libslicot/MB02CU.f b/mex/sources/libslicot/MB02CU.f new file mode 100644 index 000000000..38bddf38f --- /dev/null +++ b/mex/sources/libslicot/MB02CU.f @@ -0,0 +1,1015 @@ + SUBROUTINE MB02CU( TYPEG, K, P, Q, NB, A1, LDA1, A2, LDA2, B, LDB, + $ RNK, IPVT, CS, TOL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To bring the first blocks of a generator to proper form. +C The positive part of the generator is contained in the arrays A1 +C and A2. The negative part of the generator is contained in B. +C Transformation information will be stored and can be applied +C via SLICOT Library routine MB02CV. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPEG CHARACTER*1 +C Specifies the type of the generator, as follows: +C = 'D': generator is column oriented and rank +C deficiencies are expected; +C = 'C': generator is column oriented and rank +C deficiencies are not expected; +C = 'R': generator is row oriented and rank +C deficiencies are not expected. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in A1 to be processed. K >= 0. +C +C P (input) INTEGER +C The number of columns of the positive generator. P >= K. +C +C Q (input) INTEGER +C The number of columns in B containing the negative +C generators. +C If TYPEG = 'D', Q >= K; +C If TYPEG = 'C' or 'R', Q >= 0. +C +C NB (input) INTEGER +C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies +C the block size to be used in the blocked parts of the +C algorithm. If NB <= 0, an unblocked algorithm is used. +C +C A1 (input/output) DOUBLE PRECISION array, dimension +C (LDA1, K) +C On entry, the leading K-by-K part of this array must +C contain the leading submatrix of the positive part of the +C generator. If TYPEG = 'C', A1 is assumed to be lower +C triangular and the strictly upper triangular part is not +C referenced. If TYPEG = 'R', A1 is assumed to be upper +C triangular and the strictly lower triangular part is not +C referenced. +C On exit, if TYPEG = 'D', the leading K-by-RNK part of this +C array contains the lower trapezoidal part of the proper +C generator and information for the Householder +C transformations applied during the reduction process. +C On exit, if TYPEG = 'C', the leading K-by-K part of this +C array contains the leading lower triangular part of the +C proper generator. +C On exit, if TYPEG = 'R', the leading K-by-K part of this +C array contains the leading upper triangular part of the +C proper generator. +C +C LDA1 INTEGER +C The leading dimension of the array A1. LDA1 >= MAX(1,K). +C +C A2 (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); +C if TYPEG = 'R', dimension (LDA2, K). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-(P-K) part of this array must contain the (K+1)-st +C to P-th columns of the positive part of the generator. +C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of +C this array must contain the (K+1)-st to P-th rows of the +C positive part of the generator. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-(P-K) part of this array contains information for +C Householder transformations. +C On exit, if TYPEG = 'R', the leading (P-K)-by-K part of +C this array contains information for Householder +C transformations. +C +C LDA2 INTEGER +C The leading dimension of the array A2. +C If P = K, LDA2 >= 1; +C If P > K and (TYPEG = 'D' or TYPEG = 'C'), +C LDA2 >= MAX(1,K); +C if P > K and TYPEG = 'R', LDA2 >= P-K. +C +C B (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); +C if TYPEG = 'R', dimension (LDB, K). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-Q part of this array must contain the negative part +C of the generator. +C On entry, if TYPEG = 'R', the leading Q-by-K part of this +C array must contain the negative part of the generator. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-Q part of this array contains information for +C Householder transformations. +C On exit, if TYPEG = 'R', the leading Q-by-K part of this +C array contains information for Householder transformations. +C +C LDB INTEGER +C The leading dimension of the array B. +C If Q = 0, LDB >= 1; +C if Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), +C LDB >= MAX(1,K); +C if Q > 0 and TYPEG = 'R', LDB >= Q. +C +C RNK (output) INTEGER +C If TYPEG = 'D', the number of columns in the reduced +C generator which are found to be linearly independent. +C If TYPEG = 'C' or TYPEG = 'R', then RNK is not set. +C +C IPVT (output) INTEGER array, dimension (K) +C If TYPEG = 'D', then if IPVT(i) = k, the k-th row of the +C proper generator is the reduced i-th row of the input +C generator. +C If TYPEG = 'C' or TYPEG = 'R', this array is not +C referenced. +C +C CS (output) DOUBLE PRECISION array, dimension (x) +C If TYPEG = 'D' and P = K, x = 3*K; +C if TYPEG = 'D' and P > K, x = 5*K; +C if (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; +C if (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. +C On exit, the first x elements of this array contain +C necessary information for the SLICOT library routine +C MB02CV (Givens and modified hyperbolic rotation +C parameters, scalar factors of the Householder +C transformations). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If TYPEG = 'D', this number specifies the used tolerance +C for handling deficiencies. If the hyperbolic norm +C of two diagonal elements in the positive and negative +C generators appears to be less than or equal to TOL, then +C the corresponding columns are not reduced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,4*K), if TYPEG = 'D'; +C LDWORK >= MAX(1,MAX(NB,1)*K), if TYPEG = 'C' or 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if TYPEG = 'D', the generator represents a +C (numerically) indefinite matrix; and if TYPEG = 'C' +C or TYPEG = 'R', the generator represents a +C (numerically) semidefinite matrix. +C +C METHOD +C +C If TYPEG = 'C' or TYPEG = 'R', blocked Householder transformations +C and modified hyperbolic rotations are used to downdate the +C matrix [ A1 A2 sqrt(-1)*B ], cf. [1], [2]. +C If TYPEG = 'D', then an algorithm with row pivoting is used. In +C the first stage it maximizes the hyperbolic norm of the active +C row. As soon as the hyperbolic norm is below the threshold TOL, +C the strategy is changed. Now, in the second stage, the algorithm +C applies an LQ decomposition with row pivoting on B such that +C the Euclidean norm of the active row is maximized. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(K *( P + Q )) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D0 ) +C .. Scalar Arguments .. + CHARACTER TYPEG + INTEGER INFO, K, LDA1, LDA2, LDB, LDWORK, NB, P, Q, RNK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IPVT(*) + DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), + $ DWORK(*) +C .. Local Scalars .. + LOGICAL LCOL, LRDEF + INTEGER COL2, I, IB, IERR, IMAX, ITEMP, J, JJ, LEN, + $ NBL, PDW, PHV, POS, PST2, PVT, WRKMIN + DOUBLE PRECISION ALPHA, ALPHA2, BETA, C, DMAX, S, TAU1, TAU2, + $ TEMP, TEMP2 +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAPY2, DNRM2 + EXTERNAL IDAMAX, DLAPY2, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DGELQ2, DGEQR2, DLARF, DLARFB, DLARFG, + $ DLARFT, DLARTG, DROT, DSCAL, DSWAP, MA02FD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SIGN, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COL2 = P - K + LRDEF = LSAME( TYPEG, 'D' ) + LCOL = LSAME( TYPEG, 'C' ) + IF ( LRDEF ) THEN + WRKMIN = MAX( 1, 4*K ) + ELSE + WRKMIN = MAX( 1, NB*K, K ) + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( P.LT.K ) THEN + INFO = -3 + ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN + INFO = -4 + ELSE IF ( LDA1.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. + $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. + $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDA2.LT.( P - K ) ) ) ) THEN + INFO = -9 + ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. + $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDB.LT.MAX( 1, K ) ) ) .OR. + $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDB.LT.Q ) ) ) THEN + INFO = -11 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( K.EQ.0 .OR. ( .NOT.LRDEF .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN + IF ( LRDEF ) + $ RNK = 0 + RETURN + END IF +C + IF ( LRDEF ) THEN +C +C Deficient generator. +C + IF ( COL2.EQ.0 ) THEN + PST2 = 2*K + ELSE + PST2 = 4*K + END IF +C +C Initialize partial hyperbolic row norms. +C + RNK = 0 + PHV = 3*K +C + DO 10 I = 1, K + IPVT(I) = I + DWORK(I) = DNRM2( K, A1(I,1), LDA1 ) + 10 CONTINUE +C + DO 20 I = 1, K + DWORK(I) = DLAPY2( DWORK(I), + $ DNRM2( COL2, A2(I,1), LDA2 ) ) + DWORK(I+K) = DWORK(I) + 20 CONTINUE +C + PDW = 2*K +C + DO 30 I = 1, K + PDW = PDW + 1 + DWORK(PDW) = DNRM2( Q, B(I,1), LDB ) + 30 CONTINUE +C +C Compute factorization. +C + DO 90 I = 1, K +C +C Determine pivot row and swap if necessary. +C + PDW = I + ALPHA = ABS( DWORK(PDW) ) + BETA = ABS( DWORK(PDW+2*K) ) + DMAX = SIGN( SQRT( ABS( ALPHA - BETA ) )* + $ SQRT( ALPHA + BETA ), ALPHA - BETA ) + IMAX = I +C + DO 40 J = 1, K - I + PDW = PDW + 1 + ALPHA = ABS( DWORK(PDW) ) + BETA = ABS ( DWORK(PDW+2*K) ) + TEMP = SIGN( SQRT( ABS( ALPHA - BETA ) )* + $ SQRT( ALPHA + BETA ), ALPHA - BETA ) + IF ( TEMP.GT.DMAX ) THEN + IMAX = I + J + DMAX = TEMP + END IF + 40 CONTINUE +C +C Proceed with the reduction if the hyperbolic norm is +C beyond the threshold. +C + IF ( DMAX.GT.TOL ) THEN +C + PVT = IMAX + IF ( PVT.NE.I ) THEN + CALL DSWAP( K, A1(PVT,1), LDA1, A1(I,1), LDA1 ) + CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(I,1), LDA2 ) + CALL DSWAP( Q, B(PVT,1), LDB, B(I,1), LDB ) + ITEMP = IPVT(PVT) + IPVT(PVT) = IPVT(I) + IPVT(I) = ITEMP + DWORK(PVT) = DWORK(I) + DWORK(K+PVT) = DWORK(K+I) + DWORK(2*K+PVT) = DWORK(2*K+I) + END IF +C +C Generate and apply elementary reflectors. +C + IF ( COL2.GT.1 ) THEN + CALL DLARFG( COL2, A2(I,1), A2(I,2), LDA2, TAU2 ) + ALPHA2 = A2(I,1) + IF ( K.GT.I ) THEN + A2(I,1) = ONE + CALL DLARF( 'Right', K-I, COL2, A2(I,1), LDA2, + $ TAU2, A2(I+1,1), LDA2, DWORK(PHV+1) ) + END IF + A2(I,1) = TAU2 + ELSE IF ( COL2.GT.0 ) THEN + ALPHA2 = A2(I,1) + A2(I,1) = ZERO + END IF +C + IF ( K.GT.I ) THEN + CALL DLARFG( K-I+1, A1(I,I), A1(I,I+1), LDA1, TAU1 ) + ALPHA = A1(I,I) + A1(I,I) = ONE + CALL DLARF( 'Right', K-I, K-I+1, A1(I,I), LDA1, TAU1, + $ A1(I+1,I), LDA1, DWORK(PHV+1) ) + CS(PST2+I) = TAU1 + ELSE + ALPHA = A1(I,I) + END IF +C + IF ( COL2.GT.0 ) THEN + TEMP = ALPHA + CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) + IF ( K.GT.I ) + $ CALL DROT( K-I, A1(I+1,I), 1, A2(I+1,1), 1, C, S ) + CS(2*K+I*2-1) = C + CS(2*K+I*2) = S + END IF + A1(I,I) = ALPHA +C + IF ( Q.GT.1 ) THEN + CALL DLARFG( Q, B(I,1), B(I,2), LDB, TAU2 ) + BETA = B(I,1) + IF ( K.GT.I ) THEN + B(I,1) = ONE + CALL DLARF( 'Right', K-I, Q, B(I,1), LDB, TAU2, + $ B(I+1,1), LDB, DWORK(PHV+1) ) + END IF + B(I,1) = TAU2 + ELSE IF ( Q.GT.0 ) THEN + BETA = B(I,1) + B(I,1) = ZERO + ELSE + BETA = ZERO + END IF +C +C Create hyperbolic Givens rotation. +C + CALL MA02FD( A1(I,I), BETA, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: This should not happen. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.I ) THEN + CALL DSCAL( K-I, ONE/C, A1(I+1,I), 1 ) + CALL DAXPY( K-I, -S/C, B(I+1,1), 1, A1(I+1,I), 1 ) + CALL DSCAL( K-I, C, B(I+1,1), 1 ) + CALL DAXPY( K-I, -S, A1(I+1,I), 1, B(I+1,1), 1 ) + END IF + CS(I*2-1) = C + CS(I*2) = S +C +C Downdate the norms in A1. +C + DO 50 J = I + 1, K + TEMP = ONE - ( ABS( A1(J,I) ) / DWORK(J) )**2 + TEMP2 = ONE + P05*TEMP* + $ ( DWORK(J) / DWORK(K+J) )**2 + IF ( TEMP2.EQ.ONE ) THEN + DWORK(J) = DLAPY2( DNRM2( K-I, A1(J,I+1), LDA1 ), + $ DNRM2( COL2, A2(J,1), LDA2 ) ) + DWORK(K+J) = DWORK(J) + DWORK(2*K+J) = DNRM2( Q, B(J,1), LDB ) + ELSE + IF ( TEMP.GE.ZERO ) THEN + DWORK(J) = DWORK(J)*SQRT( TEMP ) + ELSE + DWORK(J) = -DWORK(J)*SQRT( -TEMP ) + END IF + END IF + 50 CONTINUE +C + RNK = RNK + 1 + ELSE IF ( ABS( DMAX ).LT.TOL ) THEN +C +C Displacement is positive semidefinite. +C Do an LQ decomposition with pivoting of the leftover +C negative part to find diagonal elements with almost zero +C norm. These columns cannot be removed from the +C generator. +C +C Initialize norms. +C + DO 60 J = I, K + DWORK(J) = DNRM2( Q, B(J,1), LDB ) + DWORK(J+K) = DWORK(J) + 60 CONTINUE +C + LEN = Q + POS = 1 +C + DO 80 J = I, K +C +C Generate and apply elementary reflectors. +C + PVT = ( J-1 ) + IDAMAX( K-J+1, DWORK(J), 1 ) +C +C Swap rows if necessary. +C + IF ( PVT.NE.J ) THEN + CALL DSWAP( K, A1(PVT,1), LDA1, A1(J,1), LDA1 ) + CALL DSWAP( COL2, A2(PVT,1), LDA2, A2(J,1), LDA2 ) + CALL DSWAP( Q, B(PVT,1), LDB, B(J,1), LDB ) + ITEMP = IPVT(PVT) + IPVT(PVT) = IPVT(J) + IPVT(J) = ITEMP + DWORK(PVT) = DWORK(J) + DWORK(K+PVT) = DWORK(K+J) + END IF +C +C Annihilate second part of the positive generators. +C + IF ( COL2.GT.1 ) THEN + CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) + ALPHA2 = A2(J,1) + IF ( K.GT.J ) THEN + A2(J,1) = ONE + CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, + $ TAU2, A2(J+1,1), LDA2, DWORK(PHV+1)) + END IF + A2(J,1) = TAU2 + ELSE IF ( COL2.GT.0 ) THEN + ALPHA2 = A2(J,1) + A2(J,1) = ZERO + END IF +C +C Transform first part of the positive generators to +C lower triangular form. +C + IF ( K.GT.J ) THEN + CALL DLARFG( K-J+1, A1(J,J), A1(J,J+1), LDA1, + $ TAU1 ) + ALPHA = A1(J,J) + A1(J,J) = ONE + CALL DLARF( 'Right', K-J, K-J+1, A1(J,J), LDA1, + $ TAU1, A1(J+1,J), LDA1, DWORK(PHV+1) ) + CS(PST2+J) = TAU1 + ELSE + ALPHA = A1(J,J) + END IF +C + IF ( COL2.GT.0 ) THEN + TEMP = ALPHA + CALL DLARTG( TEMP, ALPHA2, C, S, ALPHA ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, + $ S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + END IF + A1(J,J) = ALPHA +C +C Transform negative part to lower triangular form. +C + IF ( LEN.GT.1) THEN + CALL DLARFG( LEN, B(J,POS), B(J,POS+1), LDB, TAU2 ) + BETA = B(J,POS) + IF ( K.GT.J ) THEN + B(J,POS) = ONE + CALL DLARF( 'Right', K-J, LEN, B(J,POS), LDB, + $ TAU2, B(J+1,POS), LDB, DWORK(PHV+1)) + END IF + B(J,POS) = BETA + CS(J*2-1) = TAU2 + END IF +C +C Downdate the norms of the rows in the negative part. +C + DO 70 JJ = J + 1, K + IF ( DWORK(JJ).NE.ZERO ) THEN + TEMP = ONE - ( ABS( B(JJ,POS) ) + $ / DWORK(JJ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK(JJ) / DWORK(K+JJ) )**2 + IF ( TEMP2.EQ.ONE ) THEN + DWORK(JJ) = DNRM2( LEN-1, B(JJ,POS+1), LDB) + DWORK(K+JJ) = DWORK(JJ) + ELSE + IF ( TEMP.GE.ZERO ) THEN + DWORK(JJ) = DWORK(JJ)*SQRT( TEMP ) + ELSE + DWORK(JJ) = -DWORK(JJ)*SQRT( -TEMP ) + END IF + END IF + END IF + 70 CONTINUE +C + LEN = LEN - 1 + POS = POS + 1 + 80 CONTINUE +C + RETURN + ELSE +C +C Error return: +C +C Displacement is indefinite. +C Due to roundoff error, positive semidefiniteness is +C violated. This is a rather bad situation. There is no +C meaningful way to continue the computations from this +C point. +C + INFO = 1 + RETURN + END IF + 90 CONTINUE +C + ELSE IF ( LCOL ) THEN +C +C Column oriented and not deficient generator. +C +C Apply an LQ like hyperbolic/orthogonal blocked decomposition. +C + IF ( COL2.GT.0 ) THEN + NBL = MIN( COL2, NB ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 110 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DGELQ2( IB, COL2, A2(I,1), LDA2, CS(4*K+I), + $ DWORK, IERR ) + IF ( I+IB.LE.K ) THEN + CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, + $ A2(I,1), LDA2, CS(4*K+I), DWORK, K ) + CALL DLARFB( 'Right', 'No Transpose', 'Forward', + $ 'Rowwise', K-I-IB+1, COL2, IB, + $ A2(I,1), LDA2, DWORK, K, A2(I+IB,1), + $ LDA2, DWORK(IB+1), K ) + END IF +C +C Annihilate the remaining parts of A2. +C + DO 100 J = I, I + IB - 1 + IF ( COL2.GT.1 ) THEN + LEN = MIN( COL2, J-I+1 ) + CALL DLARFG( LEN, A2(J,1), A2(J,2), LDA2, TAU2 ) + ALPHA2 = A2(J,1) + IF ( K.GT.J ) THEN + A2(J,1) = ONE + CALL DLARF( 'Right', K-J, LEN, A2(J,1), LDA2, + $ TAU2, A2(J+1,1), LDA2, DWORK ) + END IF + A2(J,1) = TAU2 + ELSE + ALPHA2 = A2(J,1) + A2(J,1) = ZERO + END IF + ALPHA = A1(J,J) + CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, + $ S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + 100 CONTINUE +C + 110 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 120 J = I, K + IF ( COL2.GT.1 ) THEN + CALL DLARFG( COL2, A2(J,1), A2(J,2), LDA2, TAU2 ) + ALPHA2 = A2(J,1) + IF ( K.GT.J ) THEN + A2(J,1) = ONE + CALL DLARF( 'Right', K-J, COL2, A2(J,1), LDA2, + $ TAU2, A2(J+1,1), LDA2, DWORK ) + END IF + A2(J,1) = TAU2 + ELSE + ALPHA2 = A2(J,1) + A2(J,1) = ZERO + END IF + ALPHA = A1(J,J) + CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J+1,J), 1, A2(J+1,1), 1, C, S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + 120 CONTINUE +C + PST2 = 5*K + ELSE + PST2 = 2*K + END IF +C +C Annihilate B with hyperbolic transformations. +C + NBL = MIN( NB, Q ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 140 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DGELQ2( IB, Q, B(I,1), LDB, CS(PST2+I), DWORK, + $ IERR ) + IF ( I+IB.LE.K ) THEN + CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), + $ LDB, CS(PST2+I), DWORK, K ) + CALL DLARFB( 'Right', 'No Transpose', 'Forward', + $ 'Rowwise', K-I-IB+1, Q, IB, B(I,1), + $ LDB, DWORK, K, B(I+IB,1), LDB, + $ DWORK( IB+1 ), K ) + END IF +C +C Annihilate the remaining parts of B. +C + DO 130 J = I, I + IB - 1 + IF ( Q.GT.1 ) THEN + CALL DLARFG( J-I+1, B(J,1), B(J,2), LDB, TAU2 ) + ALPHA2 = B(J,1) + IF ( K.GT.J ) THEN + B(J,1) = ONE + CALL DLARF( 'Right', K-J, J-I+1, B(J,1), LDB, + $ TAU2, B(J+1,1), LDB, DWORK ) + END IF + B(J,1) = TAU2 + ELSE + ALPHA2 = B(J,1) + B(J,1) = ZERO + END IF +C +C Create hyperbolic rotation. +C + CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.J ) THEN + CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) + CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) + CALL DSCAL( K-J, C, B(J+1,1), 1 ) + CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) + END IF + CS(J*2-1) = C + CS(J*2) = S + 130 CONTINUE +C + 140 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 150 J = I, K + IF ( Q.GT.1 ) THEN + CALL DLARFG( Q, B(J,1), B(J,2), LDB, TAU2 ) + ALPHA2 = B(J,1) + IF ( K.GT.J ) THEN + B(J,1) = ONE + CALL DLARF( 'Right', K-J, Q, B(J,1), LDB, TAU2, + $ B(J+1,1), LDB, DWORK ) + END IF + B(J,1) = TAU2 + ELSE IF ( Q.GT.0 ) THEN + ALPHA2 = B(J,1) + B(J,1) = ZERO + END IF + IF ( Q.GT.0 ) THEN +C +C Create hyperbolic rotation. +C + CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.J ) THEN + CALL DSCAL( K-J, ONE/C, A1(J+1,J), 1 ) + CALL DAXPY( K-J, -S/C, B(J+1,1), 1, A1(J+1,J), 1 ) + CALL DSCAL( K-J, C, B(J+1,1), 1 ) + CALL DAXPY( K-J, -S, A1(J+1,J), 1, B(J+1,1), 1 ) + END IF + CS(J*2-1) = C + CS(J*2) = S + END IF + 150 CONTINUE +C + ELSE +C +C Row oriented and not deficient generator. +C + IF ( COL2.GT.0 ) THEN + NBL = MIN( NB, COL2 ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 170 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DGEQR2( COL2, IB, A2(1,I), LDA2, CS(4*K+I), + $ DWORK, IERR ) + IF ( I+IB.LE.K ) THEN + CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, + $ A2(1,I), LDA2, CS(4*K+I), DWORK, K ) + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', COL2, K-I-IB+1, IB, + $ A2(1,I), LDA2, DWORK, K, A2(1,I+IB), + $ LDA2, DWORK(IB+1), K ) + END IF +C +C Annihilate the remaining parts of A2. +C + DO 160 J = I, I + IB - 1 + IF ( COL2.GT.1 ) THEN + LEN = MIN( COL2, J-I+1 ) + CALL DLARFG( LEN, A2(1,J), A2(2,J), 1, TAU2 ) + ALPHA2 = A2(1,J) + IF ( K.GT.J ) THEN + A2(1,J) = ONE + CALL DLARF( 'Left', LEN, K-J, A2(1,J), 1, + $ TAU2, A2(1,J+1), LDA2, DWORK ) + END IF + A2(1,J) = TAU2 + ELSE + ALPHA2 = A2(1,J) + A2(1,J) = ZERO + END IF + ALPHA = A1(J,J) + CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), + $ LDA2, C, S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + 160 CONTINUE +C + 170 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 180 J = I, K + IF ( COL2.GT.1 ) THEN + CALL DLARFG( COL2, A2(1,J), A2(2,J), 1, TAU2 ) + ALPHA2 = A2(1,J) + IF ( K.GT.J ) THEN + A2(1,J) = ONE + CALL DLARF( 'Left', COL2, K-J, A2(1,J), 1, TAU2, + $ A2(1,J+1), LDA2, DWORK ) + END IF + A2(1,J) = TAU2 + ELSE + ALPHA2 = A2(1,J) + A2(1,J) = ZERO + END IF + ALPHA = A1(J,J) + CALL DLARTG( ALPHA, ALPHA2, C, S, A1(J,J) ) + IF ( K.GT.J ) + $ CALL DROT( K-J, A1(J,J+1), LDA1, A2(1,J+1), LDA2, C, + $ S ) + CS(2*K+J*2-1) = C + CS(2*K+J*2) = S + 180 CONTINUE +C + PST2 = 5*K + ELSE + PST2 = 2*K + END IF +C +C Annihilate B with hyperbolic transformations. +C + NBL = MIN( NB, Q ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 200 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DGEQR2( Q, IB, B(1,I), LDB, CS(PST2+I), DWORK, + $ IERR ) + IF ( I+IB.LE.K ) THEN + CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), + $ LDB, CS(PST2+I), DWORK, K ) + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', Q, K-I-IB+1, IB, B(1,I), + $ LDB, DWORK, K, B(1,I+IB), LDB, + $ DWORK( IB+1 ), K ) + END IF +C +C Annihilate the remaining parts of B. +C + DO 190 J = I, I + IB - 1 + IF ( Q.GT.1 ) THEN + CALL DLARFG( J-I+1, B(1,J), B(2,J), 1, TAU2 ) + ALPHA2 = B(1,J) + IF ( K.GT.J ) THEN + B(1,J) = ONE + CALL DLARF( 'Left', J-I+1, K-J, B(1,J), 1, + $ TAU2, B(1,J+1), LDB, DWORK ) + END IF + B(1,J) = TAU2 + ELSE + ALPHA2 = B(1,J) + B(1,J) = ZERO + END IF +C +C Create hyperbolic rotation. +C + CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.J ) THEN + CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) + CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), + $ LDA1 ) + CALL DSCAL( K-J, C, B(1,J+1), LDB ) + CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), + $ LDB ) + END IF + CS(J*2-1) = C + CS(J*2) = S + 190 CONTINUE +C + 200 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 210 J = I, K + IF ( Q.GT.1 ) THEN + CALL DLARFG( Q, B(1,J), B(2,J), 1, TAU2 ) + ALPHA2 = B(1,J) + IF ( K.GT.J ) THEN + B(1,J) = ONE + CALL DLARF( 'Left', Q, K-J, B(1,J), 1, TAU2, + $ B(1,J+1), LDB, DWORK ) + END IF + B(1,J) = TAU2 + ELSE IF ( Q.GT.0 ) THEN + ALPHA2 = B(1,J) + B(1,J) = ZERO + END IF + IF ( Q.GT.0 ) THEN +C +C Create hyperbolic rotation. +C + CALL MA02FD( A1(J,J), ALPHA2, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C +C Apply hyperbolic rotation. +C + IF ( K.GT.J ) THEN + CALL DSCAL( K-J, ONE/C, A1(J,J+1), LDA1 ) + CALL DAXPY( K-J, -S/C, B(1,J+1), LDB, A1(J,J+1), LDA1 + $ ) + CALL DSCAL( K-J, C, B(1,J+1), LDB ) + CALL DAXPY( K-J, -S, A1(J,J+1), LDA1, B(1,J+1), LDB + $ ) + END IF + CS(J*2-1) = C + CS(J*2) = S + END IF + 210 CONTINUE +C + END IF +C +C *** Last line of MB02CU *** + END diff --git a/mex/sources/libslicot/MB02CV.f b/mex/sources/libslicot/MB02CV.f new file mode 100644 index 000000000..f049fca50 --- /dev/null +++ b/mex/sources/libslicot/MB02CV.f @@ -0,0 +1,795 @@ + SUBROUTINE MB02CV( TYPEG, STRUCG, K, N, P, Q, NB, RNK, A1, LDA1, + $ A2, LDA2, B, LDB, F1, LDF1, F2, LDF2, G, LDG, + $ CS, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the transformations created by the SLICOT Library routine +C MB02CU on other columns / rows of the generator, contained in the +C arrays F1, F2 and G. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPEG CHARACTER*1 +C Specifies the type of the generator, as follows: +C = 'D': generator is column oriented and rank +C deficient; +C = 'C': generator is column oriented and not rank +C deficient; +C = 'R': generator is row oriented and not rank +C deficient. +C Note that this parameter must be equivalent with the +C used TYPEG in the call of MB02CU. +C +C STRUCG CHARACTER*1 +C Information about the structure of the generators, +C as follows: +C = 'T': the trailing block of the positive generator +C is upper / lower triangular, and the trailing +C block of the negative generator is zero; +C = 'N': no special structure to mention. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in A1 to be processed. K >= 0. +C +C N (input) INTEGER +C If TYPEG = 'D' or TYPEG = 'C', the number of rows in F1; +C if TYPEG = 'R', the number of columns in F1. N >= 0. +C +C P (input) INTEGER +C The number of columns of the positive generator. P >= K. +C +C Q (input) INTEGER +C The number of columns in B. +C If TYPEG = 'D', Q >= K; +C If TYPEG = 'C' or 'R', Q >= 0. +C +C NB (input) INTEGER +C On entry, if TYPEG = 'C' or TYPEG = 'R', NB specifies +C the block size to be used in the blocked parts of the +C algorithm. NB must be equivalent with the used block size +C in the routine MB02CU. +C +C RNK (input) INTEGER +C If TYPEG = 'D', the number of linearly independent columns +C in the generator as returned by MB02CU. 0 <= RNK <= K. +C If TYPEG = 'C' or 'R', the value of this parameter is +C irrelevant. +C +C A1 (input) DOUBLE PRECISION array, dimension +C (LDA1, K) +C On entry, if TYPEG = 'D', the leading K-by-K part of this +C array must contain the matrix A1 as returned by MB02CU. +C If TYPEG = 'C' or 'R', this array is not referenced. +C +C LDA1 INTEGER +C The leading dimension of the array A1. +C If TYPEG = 'D', LDA1 >= MAX(1,K); +C if TYPEG = 'C' or TYPEG = 'R', LDA1 >= 1. +C +C A2 (input) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDA2, P-K); +C if TYPEG = 'R', dimension (LDA2, K). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-(P-K) part of this array must contain the matrix +C A2 as returned by MB02CU. +C On entry, if TYPEG = 'R', the leading (P-K)-by-K part of +C this array must contain the matrix A2 as returned by +C MB02CU. +C +C LDA2 INTEGER +C The leading dimension of the array A2. +C If P = K, LDA2 >= 1; +C If P > K and (TYPEG = 'D' or TYPEG = 'C'), +C LDA2 >= MAX(1,K); +C if P > K and TYPEG = 'R', LDA2 >= P-K. +C +C B (input) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDB, Q); +C if TYPEG = 'R', dimension (LDB, K). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C K-by-Q part of this array must contain the matrix B as +C returned by MB02CU. +C On entry, if TYPEG = 'R', the leading Q-by-K part of this +C array must contain the matrix B as returned by MB02CU. +C +C LDB INTEGER +C The leading dimension of the array B. +C If Q = 0, LDB >= 1; +C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), +C LDB >= MAX(1,K); +C if Q > 0 and TYPEG = 'R', LDB >= Q. +C +C F1 (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF1, K); +C if TYPEG = 'R', dimension (LDF1, N). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-K part of this array must contain the first part +C of the positive generator to be processed. +C On entry, if TYPEG = 'R', the leading K-by-N part of this +C array must contain the first part of the positive +C generator to be processed. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-K part of this array contains the first part of the +C transformed positive generator. +C On exit, if TYPEG = 'R', the leading K-by-N part of this +C array contains the first part of the transformed positive +C generator. +C +C LDF1 INTEGER +C The leading dimension of the array F1. +C If TYPEG = 'D' or TYPEG = 'C', LDF1 >= MAX(1,N); +C if TYPEG = 'R', LDF1 >= MAX(1,K). +C +C F2 (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDF2, P-K); +C if TYPEG = 'R', dimension (LDF2, N). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-(P-K) part of this array must contain the second part +C of the positive generator to be processed. +C On entry, if TYPEG = 'R', the leading (P-K)-by-N part of +C this array must contain the second part of the positive +C generator to be processed. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-(P-K) part of this array contains the second part of +C the transformed positive generator. +C On exit, if TYPEG = 'R', the leading (P-K)-by-N part of +C this array contains the second part of the transformed +C positive generator. +C +C LDF2 INTEGER +C The leading dimension of the array F2. +C If P = K, LDF2 >= 1; +C If P > K and (TYPEG = 'D' or TYPEG = 'C'), +C LDF2 >= MAX(1,N); +C if P > K and TYPEG = 'R', LDF2 >= P-K. +C +C G (input/output) DOUBLE PRECISION array, +C if TYPEG = 'D' or TYPEG = 'C', dimension (LDG, Q); +C if TYPEG = 'R', dimension (LDG, N). +C On entry, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-Q part of this array must contain the negative part +C of the generator to be processed. +C On entry, if TYPEG = 'R', the leading Q-by-N part of this +C array must contain the negative part of the generator to +C be processed. +C On exit, if TYPEG = 'D' or TYPEG = 'C', the leading +C N-by-Q part of this array contains the transformed +C negative generator. +C On exit, if TYPEG = 'R', the leading Q-by-N part of this +C array contains the transformed negative generator. +C +C LDG INTEGER +C The leading dimension of the array G. +C If Q = 0, LDG >= 1; +C If Q > 0 and (TYPEG = 'D' or TYPEG = 'C'), +C LDG >= MAX(1,N); +C if Q > 0 and TYPEG = 'R', LDG >= Q. +C +C CS (input) DOUBLE PRECISION array, dimension (x) +C If TYPEG = 'D' and P = K, x = 3*K; +C If TYPEG = 'D' and P > K, x = 5*K; +C If (TYPEG = 'C' or TYPEG = 'R') and P = K, x = 4*K; +C If (TYPEG = 'C' or TYPEG = 'R') and P > K, x = 6*K. +C On entry, the first x elements of this array must contain +C Givens and modified hyperbolic rotation parameters, and +C scalar factors of the Householder transformations as +C returned by MB02CU. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = -23, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C TYPEG = 'D': LDWORK >= MAX(1,N); +C (TYPEG = 'C' or TYPEG = 'R') and NB <= 0: +C LDWORK >= MAX(1,N); +C (TYPEG = 'C' or TYPEG = 'R') and NB >= 1: +C LDWORK >= MAX(1,( N + K )*NB). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(N*K*( P + Q )) floating point operations. +C +C METHOD +C +C The Householder transformations and modified hyperbolic rotations +C computed by SLICOT Library routine MB02CU are applied to the +C corresponding parts of the matrices F1, F2 and G. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C March 2004, March 2007. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER STRUCG, TYPEG + INTEGER INFO, K, LDA1, LDA2, LDB, LDF1, LDF2, LDG, + $ LDWORK, N, NB, P, Q, RNK +C .. Array Arguments .. + DOUBLE PRECISION A1(LDA1,*), A2(LDA2,*), B(LDB,*), CS(*), + $ DWORK(*), F1(LDF1,*), F2(LDF2,*), G(LDG,*) +C .. Local Scalars .. + INTEGER COL2, I, IB, J, JJ, LEN, NBL, POS, PST2, + $ WRKMIN + DOUBLE PRECISION ALPHA, BETA, C, S, TAU, TEMP + LOGICAL LRDEF, LTRI, LCOL +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLARF, DLARFB, DLARFT, DROT, DSCAL, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COL2 = MAX( 0, P - K ) + LRDEF = LSAME( TYPEG, 'D' ) + LCOL = LSAME( TYPEG, 'C' ) + LTRI = LSAME( STRUCG, 'T' ) + IF ( LRDEF ) THEN + WRKMIN = MAX( 1, N ) + ELSE + IF ( NB.GE.1 ) THEN + WRKMIN = MAX( 1, ( N + K )*NB ) + ELSE + WRKMIN = MAX( 1, N ) + END IF + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( LCOL .OR. LRDEF .OR. LSAME( TYPEG, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRI .OR. LSAME( STRUCG, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( P.LT.K ) THEN + INFO = -5 + ELSE IF ( Q.LT.0 .OR. ( LRDEF .AND. Q.LT.K ) ) THEN + INFO = -6 + ELSE IF ( LRDEF .AND. ( RNK.LT.0 .OR. RNK.GT.K ) ) THEN + INFO = -8 + ELSE IF ( ( LDA1.LT.1 ) .OR. ( LRDEF .AND. LDA1.LT.K ) ) THEN + INFO = -10 + ELSE IF ( ( ( P.EQ.K ) .AND. LDA2.LT.1 ) .OR. + $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDA2.LT.MAX( 1, K ) ) ) .OR. + $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDA2.LT.( P-K ) ) ) ) THEN + INFO = -12 + ELSE IF ( ( ( Q.EQ.0 ) .AND. LDB.LT.1 ) .OR. + $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDB.LT.MAX( 1, K ) ) ) .OR. + $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDB.LT.Q ) ) ) THEN + INFO = -14 + ELSE IF ( ( LRDEF .OR. LCOL ) .AND. LDF1.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF ( (.NOT.( LRDEF .OR. LCOL ) ) .AND. LDF1.LT.MAX( 1, K ) ) + $ THEN + INFO = -16 + ELSE IF ( ( ( P.EQ.K ) .AND. LDF2.LT.1 ) .OR. + $ ( ( P.GT.K ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDF2.LT.MAX( 1, N ) ) ) .OR. + $ ( ( P.GT.K ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDF2.LT.( P-K ) ) ) ) THEN + INFO = -18 + ELSE IF ( ( ( Q.EQ.0 ) .AND. LDG.LT.1 ) .OR. + $ ( ( Q.GT.0 ) .AND. ( LRDEF .OR. LCOL ) .AND. + $ ( LDG.LT.MAX( 1, N ) ) ) .OR. + $ ( ( Q.GT.0 ) .AND. .NOT.( LRDEF .OR. LCOL ) .AND. + $ ( LDG.LT.Q ) ) ) THEN + INFO = -20 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -23 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CV', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N ).EQ.0 .OR. + $ ( ( .NOT.LRDEF ) .AND. Q.EQ.0 .AND. P.EQ.K ) ) THEN + RETURN + END IF +C + IF ( LRDEF ) THEN +C +C Deficient generator. +C + IF ( COL2.EQ.0 ) THEN + PST2 = 2*K + ELSE + PST2 = 4*K + END IF +C + DO 10 I = 1, RNK +C +C Apply elementary reflectors. +C + IF ( COL2.GT.1 ) THEN + TAU = A2(I,1) + A2(I,1) = ONE + CALL DLARF( 'Right', N, COL2, A2(I,1), LDA2, TAU, F2, + $ LDF2, DWORK ) + A2(I,1) = TAU + END IF +C + IF ( K.GT.I ) THEN + ALPHA = A1(I,I) + A1(I,I) = ONE + CALL DLARF( 'Right', N, K-I+1, A1(I,I), LDA1, CS(PST2+I), + $ F1(1,I), LDF1, DWORK ) + A1(I,I) = ALPHA + END IF +C + IF ( COL2.GT.0 ) THEN + C = CS(2*K+I*2-1) + S = CS(2*K+I*2) + CALL DROT( N, F1(1,I), 1, F2, 1, C, S ) + END IF +C + IF ( Q.GT.1 ) THEN + TAU = B(I,1) + B(I,1) = ONE + CALL DLARF( 'Right', N, Q, B(I,1), LDB, TAU, + $ G, LDG, DWORK ) + B(I,1) = TAU + END IF +C +C Apply hyperbolic rotation. +C + C = CS(I*2-1) + S = CS(I*2) + CALL DSCAL( N, ONE/C, F1(1,I), 1 ) + CALL DAXPY( N, -S/C, G(1,1), 1, F1(1,I), 1 ) + CALL DSCAL( N, C, G(1,1), 1 ) + CALL DAXPY( N, -S, F1(1,I), 1, G(1,1), 1 ) + 10 CONTINUE +C + LEN = Q + POS = 1 +C + DO 20 J = RNK + 1, K +C +C Apply the reductions working on singular rows. +C + IF ( COL2.GT.1 ) THEN + TAU = A2(J,1) + A2(J,1) = ONE + CALL DLARF( 'Right', N, COL2, A2(J,1), LDA2, TAU, F2, + $ LDF2, DWORK ) + A2(J,1) = TAU + END IF + IF ( K.GT.J ) THEN + ALPHA = A1(J,J) + A1(J,J) = ONE + CALL DLARF( 'Right', N, K-J+1, A1(J,J), LDA1, CS(PST2+J), + $ F1(1,J), LDF1, DWORK ) + A1(J,J) = ALPHA + END IF + IF ( COL2.GT.0 ) THEN + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( N, F1(1,J), 1, F2, 1, C, S ) + END IF + IF ( LEN.GT.1 ) THEN + BETA = B(J,POS) + B(J,POS) = ONE + CALL DLARF( 'Right', N, LEN, B(J,POS), LDB, CS(J*2-1), + $ G(1,POS), LDG, DWORK ) + B(J,POS) = BETA + END IF + LEN = LEN - 1 + POS = POS + 1 + 20 CONTINUE +C + ELSE IF ( LCOL ) THEN +C +C Column oriented and not deficient generator. +C +C Apply an LQ like hyperbolic/orthogonal blocked decomposition. +C + IF ( LTRI ) THEN + LEN = MAX( N - K, 0 ) + ELSE + LEN = N + END IF + IF ( COL2.GT.0 ) THEN +C + NBL = MIN( COL2, NB ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 50 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DLARFT( 'Forward', 'Rowwise', COL2, IB, A2(I,1), + $ LDA2, CS(4*K+I), DWORK, N+K ) + CALL DLARFB( 'Right', 'No Transpose', 'Forward', + $ 'Rowwise', LEN, COL2, IB, A2(I,1), + $ LDA2, DWORK, N+K, F2, LDF2, + $ DWORK(IB+1), N+K ) +C + DO 40 J = I, I + IB - 1 + TAU = A2(J,1) + A2(J,1) = ONE + CALL DLARF( 'Right', LEN, MIN( COL2, J-I+1 ), + $ A2(J,1), LDA2, TAU, F2, LDF2, DWORK ) + A2(J,1) = TAU + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) + IF ( LTRI ) THEN + LEN = LEN + 1 + TEMP = F1(LEN,J) + F1(LEN,J) = C*TEMP + F2(LEN,1) = -S*TEMP +C + DO 30 JJ = 2, COL2 + F2(LEN,JJ) = ZERO + 30 CONTINUE +C + END IF + 40 CONTINUE +C + 50 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 70 J = I, K + IF ( COL2.GT.1 ) THEN + TAU = A2(J,1) + A2(J,1) = ONE + CALL DLARF( 'Right', LEN, COL2, A2(J,1), LDA2, TAU, + $ F2, LDF2, DWORK ) + A2(J,1) = TAU + END IF +C + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( LEN, F1(1,J), 1, F2, 1, C, S ) + IF ( LTRI ) THEN + LEN = LEN + 1 + TEMP = F1(LEN,J) + F1(LEN,J) = C*TEMP + F2(LEN,1) = -S*TEMP +C + DO 60 JJ = 2, COL2 + F2(LEN,JJ) = ZERO + 60 CONTINUE +C + END IF + 70 CONTINUE +C + PST2 = 5*K + ELSE + PST2 = 2*K + END IF +C + IF ( LTRI ) THEN + LEN = N - K + ELSE + LEN = N + END IF +C + NBL = MIN( Q, NB ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 100 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DLARFT( 'Forward', 'Rowwise', Q, IB, B(I,1), + $ LDB, CS(PST2+I), DWORK, N+K ) + CALL DLARFB( 'Right', 'NonTranspose', 'Forward', + $ 'Rowwise', LEN, Q, IB, B(I,1), + $ LDB, DWORK, N+K, G, LDG, + $ DWORK(IB+1), N+K ) +C + DO 90 J = I, I + IB - 1 + TAU = B(J,1) + B(J,1) = ONE + CALL DLARF( 'Right', LEN, J-I+1, B(J,1), LDB, + $ TAU, G, LDG, DWORK ) + B(J,1) = TAU +C +C Apply hyperbolic rotation. +C + C = CS(J*2-1) + S = CS(J*2) + CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) + CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) + CALL DSCAL( LEN, C, G, 1 ) + CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) + IF ( LTRI ) THEN + LEN = LEN + 1 + G(LEN,1) = -S/C*F1(LEN,J) + F1(LEN,J) = F1(LEN,J) / C +C + DO 80 JJ = 2, Q + G(LEN,JJ) = ZERO + 80 CONTINUE +C + END IF + 90 CONTINUE +C + 100 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 120 J = I, K + IF ( Q.GT.1 ) THEN + TAU = B(J,1) + B(J,1) = ONE + CALL DLARF( 'Right', LEN, Q, B(J,1), LDB, TAU, + $ G, LDG, DWORK ) + B(J,1) = TAU + END IF + IF ( Q.GT.0 ) THEN +C +C Apply hyperbolic rotation. +C + C = CS(J*2-1) + S = CS(J*2) + CALL DSCAL( LEN, ONE/C, F1(1,J), 1 ) + CALL DAXPY( LEN, -S/C, G, 1, F1(1,J), 1 ) + CALL DSCAL( LEN, C, G, 1 ) + CALL DAXPY( LEN, -S, F1(1,J), 1, G, 1 ) + IF ( LTRI ) THEN + LEN = LEN + 1 + G(LEN,1) = -S/C*F1(LEN,J) + F1(LEN,J) = F1(LEN,J) / C +C + DO 110 JJ = 2, Q + G(LEN,JJ) = ZERO + 110 CONTINUE +C + END IF + END IF + 120 CONTINUE +C + ELSE +C +C Row oriented and not deficient generator. +C + IF ( LTRI ) THEN + LEN = MAX( N - K, 0 ) + ELSE + LEN = N + END IF +C + IF ( COL2.GT.0 ) THEN + NBL = MIN( NB, COL2 ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 150 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DLARFT( 'Forward', 'Columnwise', COL2, IB, + $ A2(1,I), LDA2, CS(4*K+I), DWORK, N+K ) + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', COL2, LEN, IB, A2(1,I), + $ LDA2, DWORK, N+K, F2, LDF2, + $ DWORK(IB+1), N+K ) +C + DO 140 J = I, I + IB - 1 + TAU = A2(1,J) + A2(1,J) = ONE + CALL DLARF( 'Left', MIN( COL2, J-I+1 ), LEN, + $ A2(1,J), 1, TAU, F2, LDF2, DWORK ) + A2(1,J) = TAU + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) + IF ( LTRI ) THEN + LEN = LEN + 1 + TEMP = F1(J,LEN) + F1(J,LEN) = C*TEMP + F2(1,LEN) = -S*TEMP +C + DO 130 JJ = 2, COL2 + F2(JJ,LEN) = ZERO + 130 CONTINUE +C + END IF + 140 CONTINUE +C + 150 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 170 J = I, K + IF ( COL2.GT.1 ) THEN + TAU = A2(1,J) + A2(1,J) = ONE + CALL DLARF( 'Left', COL2, LEN, A2(1,J), 1, TAU, + $ F2, LDF2, DWORK ) + A2(1,J) = TAU + END IF +C + C = CS(2*K+J*2-1) + S = CS(2*K+J*2) + CALL DROT( LEN, F1(J,1), LDF1, F2, LDF2, C, S ) + IF ( LTRI ) THEN + LEN = LEN + 1 + TEMP = F1(J,LEN) + F1(J,LEN) = C*TEMP + F2(1,LEN) = -S*TEMP +C + DO 160 JJ = 2, COL2 + F2(JJ,LEN) = ZERO + 160 CONTINUE +C + END IF + 170 CONTINUE +C + PST2 = 5*K + ELSE + PST2 = 2*K + END IF +C + IF ( LTRI ) THEN + LEN = N - K + ELSE + LEN = N + END IF +C + NBL = MIN( Q, NB ) + IF ( NBL.GT.0 ) THEN +C +C Blocked version. +C + DO 200 I = 1, K - NBL + 1, NBL + IB = MIN( K-I+1, NBL ) + CALL DLARFT( 'Forward', 'Columnwise', Q, IB, B(1,I), + $ LDB, CS(PST2+I), DWORK, N+K ) + CALL DLARFB( 'Left', 'Transpose', 'Forward', + $ 'Columnwise', Q, LEN, IB, B(1,I), + $ LDB, DWORK, N+K, G, LDG, + $ DWORK(IB+1), N+K ) +C + DO 190 J = I, I + IB - 1 + TAU = B(1,J) + B(1,J) = ONE + CALL DLARF( 'Left', J-I+1, LEN, B(1,J), 1, + $ TAU, G, LDG, DWORK ) + B(1,J) = TAU +C +C Apply hyperbolic rotation. +C + C = CS(J*2-1) + S = CS(J*2) + CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) + CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) + CALL DSCAL( LEN, C, G, LDG ) + CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) + IF ( LTRI ) THEN + LEN = LEN + 1 + G(1,LEN) = -S/C*F1(J,LEN) + F1(J,LEN) = F1(J,LEN) / C +C + DO 180 JJ = 2, Q + G(JJ,LEN) = ZERO + 180 CONTINUE +C + END IF + 190 CONTINUE +C + 200 CONTINUE +C + ELSE + I = 1 + END IF +C +C Unblocked version for the last or only block. +C + DO 220 J = I, K + IF ( Q.GT.1 ) THEN + TAU = B(1,J) + B(1,J) = ONE + CALL DLARF( 'Left', Q, LEN, B(1,J), 1, TAU, + $ G, LDG, DWORK ) + B(1,J) = TAU + END IF + IF ( Q.GT.0 ) THEN +C +C Apply hyperbolic rotation. +C + C = CS(J*2-1) + S = CS(J*2) + CALL DSCAL( LEN, ONE/C, F1(J,1), LDF1 ) + CALL DAXPY( LEN, -S/C, G, LDG, F1(J,1), LDF1 ) + CALL DSCAL( LEN, C, G, LDG ) + CALL DAXPY( LEN, -S, F1(J,1), LDF1, G, LDG ) + IF ( LTRI ) THEN + LEN = LEN + 1 + G(1,LEN) = -S/C*F1(J,LEN) + F1(J,LEN) = F1(J,LEN) / C +C + DO 210 JJ = 2, Q + G(JJ,LEN) = ZERO + 210 CONTINUE +C + END IF + END IF + 220 CONTINUE +C + END IF +C +C *** Last line of MB02CV *** + END diff --git a/mex/sources/libslicot/MB02CX.f b/mex/sources/libslicot/MB02CX.f new file mode 100644 index 000000000..be4989cbf --- /dev/null +++ b/mex/sources/libslicot/MB02CX.f @@ -0,0 +1,318 @@ + SUBROUTINE MB02CX( TYPET, P, Q, K, A, LDA, B, LDB, CS, LCS, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To bring the first blocks of a generator in proper form. +C The columns / rows of the positive and negative generators +C are contained in the arrays A and B, respectively. +C Transformation information will be stored and can be applied +C via SLICOT Library routine MB02CY. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of the generator, as follows: +C = 'R': A and B are the first blocks of the rows of the +C positive and negative generators; +C = 'C': A and B are the first blocks of the columns of the +C positive and negative generators. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C P (input) INTEGER +C The number of rows / columns in A containing the positive +C generators. P >= 0. +C +C Q (input) INTEGER +C The number of rows / columns in B containing the negative +C generators. Q >= 0. +C +C K (input) INTEGER +C The number of columns / rows in A and B to be processed. +C Normally, the size of the first block. P >= K >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA, K) / (LDA, P) +C On entry, the leading P-by-K upper / K-by-P lower +C triangular part of this array must contain the rows / +C columns of the positive part in the first block of the +C generator. +C On exit, the leading P-by-K upper / K-by-P lower +C triangular part of this array contains the rows / columns +C of the positive part in the first block of the proper +C generator. +C The lower / upper trapezoidal part is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,P), if TYPET = 'R'; +C LDA >= MAX(1,K), if TYPET = 'C'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB, K) / (LDB, Q) +C On entry, the leading Q-by-K / K-by-Q part of this array +C must contain the rows / columns of the negative part in +C the first block of the generator. +C On exit, the leading Q-by-K / K-by-Q part of this array +C contains part of the necessary information for the +C Householder transformations. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,Q), if TYPET = 'R'; +C LDB >= MAX(1,K), if TYPET = 'C'. +C +C CS (output) DOUBLE PRECISION array, dimension (LCS) +C On exit, the leading 2*K + MIN(K,Q) part of this array +C contains necessary information for the SLICOT Library +C routine MB02CY (modified hyperbolic rotation parameters +C and scalar factors of the Householder transformations). +C +C LCS INTEGER +C The length of the array CS. LCS >= 2*K + MIN(K,Q). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -12, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,K). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: succesful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The matrix +C associated with the generator is not (numerically) +C positive definite. +C +C METHOD +C +C If TYPET = 'R', a QR decomposition of B is first computed. +C Then, the elements below the first row of each column i of B +C are annihilated by a Householder transformation modifying the +C first element in that column. This first element, in turn, is +C then annihilated by a modified hyperbolic rotation, acting also +C on the i-th row of A. +C +C If TYPET = 'C', an LQ decomposition of B is first computed. +C Then, the elements on the right of the first column of each row i +C of B are annihilated by a Householder transformation modifying the +C first element in that row. This first element, in turn, is +C then annihilated by a modified hyperbolic rotation, acting also +C on the i-th column of A. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2000, +C February 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPET + INTEGER INFO, K, LDA, LDB, LCS, LDWORK, P, Q +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*) +C .. Local Scalars .. + LOGICAL ISROW + INTEGER I, IERR + DOUBLE PRECISION ALPHA, BETA, C, MAXWRK, S, TAU +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DGELQF, DGEQRF, DLARF, DLARFG, DSCAL, + $ MA02FD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( P.LT.0 ) THEN + INFO = -2 + ELSE IF ( Q.LT.0 ) THEN + INFO = -3 + ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN + INFO = -4 + ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. + $ ( .NOT.ISROW .AND. LDA.LT.K ) ) THEN + INFO = -6 + ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. + $ ( .NOT.ISROW .AND. LDB.LT.K ) ) THEN + INFO = -8 + ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN + INFO = -10 + ELSE IF ( LDWORK.LT.MAX( 1, K ) ) THEN + DWORK(1) = MAX( 1, K ) + INFO = -12 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( Q, K ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + IF ( ISROW ) THEN +C +C The generator is row wise stored. +C +C Step 0: Do QR decomposition of B. +C + CALL DGEQRF ( Q, K, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) + MAXWRK = DWORK(1) +C + DO 10 I = 1, K +C +C Step 1: annihilate the i-th column of B. +C + IF ( Q.GT.1 ) THEN + CALL DLARFG( MIN( I, Q ), B(1,I), B(2,I), 1, TAU ) + ALPHA = B(1,I) + B(1,I) = ONE + IF ( K.GT.I ) + $ CALL DLARF( 'Left', MIN( I, Q ), K-I, B(1,I), 1, TAU, + $ B(1,I+1), LDB, DWORK ) + B(1,I) = ALPHA + ELSE + ALPHA = B(1,I) + TAU = ZERO + END IF +C +C Step 2: annihilate the top entry of the column. +C + BETA = A(I,I) + CALL MA02FD( BETA, ALPHA, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + CS(I*2-1) = C + CS(I*2) = S + CALL DSCAL( K-I+1, ONE/C, A(I,I), LDA ) + CALL DAXPY( K-I+1, -S/C, B(1,I), LDB, A(I,I), LDA ) + CALL DSCAL( K-I+1, C, B(1,I), LDB ) + CALL DAXPY( K-I+1, -S, A(I,I), LDA, B(1,I), LDB ) + B(1,I) = TAU + 10 CONTINUE +C + ELSE +C +C The generator is column wise stored. +C +C Step 0: Do LQ decomposition of B. +C + CALL DGELQF ( K, Q, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR ) + MAXWRK = DWORK(1) +C + DO 20 I = 1, K +C +C Step 1: annihilate the i-th row of B. +C + IF ( Q.GT.1 ) THEN + CALL DLARFG( MIN( I, Q ), B(I,1), B(I,2), LDB, TAU ) + ALPHA = B(I,1) + B(I,1) = ONE + IF ( K.GT.I ) + $ CALL DLARF( 'Right', K-I, MIN( I, Q ), B(I,1), LDB, + $ TAU, B(I+1,1), LDB, DWORK ) + B(I,1) = ALPHA + ELSE + ALPHA = B(I,1) + TAU = ZERO + END IF +C +C Step 2: annihilate the left entry of the row. +C + BETA = A(I,I) + CALL MA02FD( BETA, ALPHA, C, S, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + CS(I*2-1) = C + CS(I*2) = S + CALL DSCAL( K-I+1, ONE/C, A(I,I), 1 ) + CALL DAXPY( K-I+1, -S/C, B(I,1), 1, A(I,I), 1 ) + CALL DSCAL( K-I+1, C, B(I,1), 1 ) + CALL DAXPY( K-I+1, -S, A(I,I), 1, B(I,1), 1 ) + B(I,1) = TAU + 20 CONTINUE +C + END IF +C + DWORK(1) = MAXWRK +C + RETURN +C +C *** Last line of MB02CX *** + END diff --git a/mex/sources/libslicot/MB02CY.f b/mex/sources/libslicot/MB02CY.f new file mode 100644 index 000000000..7d977dee9 --- /dev/null +++ b/mex/sources/libslicot/MB02CY.f @@ -0,0 +1,372 @@ + SUBROUTINE MB02CY( TYPET, STRUCG, P, Q, N, K, A, LDA, B, LDB, H, + $ LDH, CS, LCS, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the transformations created by the SLICOT Library +C routine MB02CX on other columns / rows of the generator, +C contained in the arrays A and B of positive and negative +C generators, respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of the generator, as follows: +C = 'R': A and B are additional columns of the generator; +C = 'C': A and B are additional rows of the generator. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C STRUCG CHARACTER*1 +C Information about the structure of the two generators, +C as follows: +C = 'T': the trailing block of the positive generator +C is lower / upper triangular, and the trailing +C block of the negative generator is zero; +C = 'N': no special structure to mention. +C +C Input/Output Parameters +C +C P (input) INTEGER +C The number of rows / columns in A containing the positive +C generators. P >= 0. +C +C Q (input) INTEGER +C The number of rows / columns in B containing the negative +C generators. Q >= 0. +C +C N (input) INTEGER +C The number of columns / rows in A and B to be processed. +C N >= 0. +C +C K (input) INTEGER +C The number of columns / rows in H. P >= K >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA, N) / (LDA, P) +C On entry, the leading P-by-N / N-by-P part of this array +C must contain the positive part of the generator. +C On exit, the leading P-by-N / N-by-P part of this array +C contains the transformed positive part of the generator. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,P), if TYPET = 'R'; +C LDA >= MAX(1,N), if TYPET = 'C'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB, N) / (LDB, Q) +C On entry, the leading Q-by-N / N-by-Q part of this array +C must contain the negative part of the generator. +C On exit, the leading Q-by-N / N-by-Q part of this array +C contains the transformed negative part of the generator. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,Q), if TYPET = 'R'; +C LDB >= MAX(1,N), if TYPET = 'C'. +C +C H (input) DOUBLE PRECISION array, dimension +C (LDH, K) / (LDH, Q) +C The leading Q-by-K / K-by-Q part of this array must +C contain part of the necessary information for the +C Householder transformations computed by SLICOT Library +C routine MB02CX. +C +C LDH INTEGER +C The leading dimension of the array H. +C LDH >= MAX(1,Q), if TYPET = 'R'; +C LDH >= MAX(1,K), if TYPET = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (LCS) +C The leading 2*K + MIN(K,Q) part of this array must +C contain the necessary information for modified hyperbolic +C rotations and the scalar factors of the Householder +C transformations computed by SLICOT Library routine MB02CX. +C +C LCS INTEGER +C The length of the array CS. LCS >= 2*K + MIN(K,Q). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: succesful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Householder transformations and modified hyperbolic rotations +C computed by SLICOT Library routine MB02CX are applied to the +C corresponding parts of the matrices A and B. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, June 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2000, +C February 2004, March 2007. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, K, LDA, LDB, LCS, LDH, LDWORK, N, P, Q + CHARACTER STRUCG, TYPET +C .. Array Arguments .. + DOUBLE PRECISION A(LDA, *), B(LDB, *), CS(*), DWORK(*), H(LDH,*) +C .. Local Scalars .. + LOGICAL ISLWR, ISROW + INTEGER I, IERR, CI, MAXWRK + DOUBLE PRECISION C, S, TAU +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DLARF, DLASET, DORMLQ, DORMQR, DSCAL, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + ISROW = LSAME( TYPET, 'R' ) + ISLWR = LSAME( STRUCG, 'T' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( ISLWR .OR. LSAME( STRUCG, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( P.LT.0 ) THEN + INFO = -3 + ELSE IF ( Q.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN + INFO = -6 + ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR. + $ ( .NOT.ISROW .AND. LDA.LT.N ) ) THEN + INFO = -8 + ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR. + $ ( .NOT.ISROW .AND. LDB.LT.N ) ) THEN + INFO = -10 + ELSE IF ( LDH.LT.1 .OR. ( ISROW .AND. LDH.LT.Q ) .OR. + $ ( .NOT.ISROW .AND. LDH.LT.K ) ) THEN + INFO = -12 + ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN + INFO = -14 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = MAX( 1, N ) + INFO = -16 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02CY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( N, K, Q ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Applying the transformations. +C + IF ( ISROW ) THEN +C +C The generator is row wise stored. +C + IF ( ISLWR ) THEN +C + DO 10 I = 1, K +C +C Apply Householder transformation avoiding touching of +C zero blocks. +C + CI = N - K + I - 1 + TAU = H(1,I) + H(1,I) = ONE + CALL DLARF( 'Left', MIN( I, Q ), CI, H(1,I), 1, TAU, B, + $ LDB, DWORK ) + H(1,I) = TAU +C +C Now apply the hyperbolic rotation under the assumption +C that A(I, N-K+I+1:N) and B(1, N-K+I:N) are zero. +C + C = CS(I*2-1) + S = CS(I*2) +C + CALL DSCAL( CI, ONE/C, A(I,1), LDA ) + CALL DAXPY( CI, -S/C, B(1,1), LDB, A(I,1), LDA ) + CALL DSCAL( CI, C, B(1,1), LDB ) + CALL DAXPY( CI, -S, A(I,1), LDA, B(1,1), LDB ) +C + B(1,N-K+I) = -S/C * A(I,N-K+I) + A(I,N-K+I) = ONE/C * A(I,N-K+I) +C +C All below B(1,N-K+I) should be zero. +C + IF( Q.GT.1 ) + $ CALL DLASET( 'All', Q-1, 1, ZERO, ZERO, B(2,N-K+I), + $ 1 ) + 10 CONTINUE +C + ELSE +C +C Apply the QR reduction on B. +C + CALL DORMQR( 'Left', 'Transpose', Q, N, MIN( K, Q ), H, + $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) + MAXWRK = DWORK(1) +C + DO 20 I = 1, K +C +C Apply Householder transformation. +C + TAU = H(1,I) + H(1,I) = ONE + CALL DLARF( 'Left', MIN( I, Q ), N, H(1,I), 1, TAU, B, + $ LDB, DWORK ) + H(1,I) = TAU +C +C Apply Hyperbolic Rotation. +C + C = CS(I*2-1) + S = CS(I*2) +C + CALL DSCAL( N, ONE/C, A(I,1), LDA ) + CALL DAXPY( N, -S/C, B(1,1), LDB, A(I,1), LDA ) + CALL DSCAL( N, C, B(1,1), LDB ) + CALL DAXPY( N, -S, A(I,1), LDA, B(1,1), LDB ) + 20 CONTINUE +C + END IF +C + ELSE +C +C The generator is column wise stored. +C + IF ( ISLWR ) THEN +C + DO 30 I = 1, K +C +C Apply Householder transformation avoiding touching zeros. +C + CI = N - K + I - 1 + TAU = H(I,1) + H(I,1) = ONE + CALL DLARF( 'Right', CI, MIN( I, Q ), H(I,1), LDH, TAU, + $ B, LDB, DWORK ) + H(I,1) = TAU +C +C Apply Hyperbolic Rotation. +C + C = CS(I*2-1) + S = CS(I*2) +C + CALL DSCAL( CI, ONE/C, A(1,I), 1 ) + CALL DAXPY( CI, -S/C, B(1,1), 1, A(1,I), 1 ) + CALL DSCAL( CI, C, B(1,1), 1 ) + CALL DAXPY( CI, -S, A(1,I), 1, B(1,1), 1 ) +C + B(N-K+I,1) = -S/C * A(N-K+I,I) + A(N-K+I,I) = ONE/C * A(N-K+I,I) +C +C All elements right behind B(N-K+I,1) should be zero. +C + IF( Q.GT.1 ) + $ CALL DLASET( 'All', 1, Q-1, ZERO, ZERO, B(N-K+I,2), + $ LDB ) + 30 CONTINUE +C + ELSE +C +C Apply the LQ reduction on B. +C + CALL DORMLQ( 'Right', 'Transpose', N, Q, MIN( K, Q ), H, + $ LDH, CS(2*K+1), B, LDB, DWORK, LDWORK, IERR ) + MAXWRK = DWORK(1) +C + DO 40 I = 1, K +C +C Apply Householder transformation. +C + TAU = H(I,1) + H(I,1) = ONE + CALL DLARF( 'Right', N, MIN( I, Q ), H(I,1), LDH, TAU, B, + $ LDB, DWORK ) + H(I,1) = TAU +C +C Apply Hyperbolic Rotation. +C + C = CS(I*2-1) + S = CS(I*2) +C + CALL DSCAL( N, ONE/C, A(1,I), 1 ) + CALL DAXPY( N, -S/C, B(1,1), 1, A(1,I), 1 ) + CALL DSCAL( N, C, B(1,1), 1 ) + CALL DAXPY( N, -S, A(1,I), 1, B(1,1), 1 ) + 40 CONTINUE +C + END IF +C + END IF +C + DWORK(1) = MAX( MAXWRK, N ) +C + RETURN +C +C *** Last line of MB02CY *** + END diff --git a/mex/sources/libslicot/MB02DD.f b/mex/sources/libslicot/MB02DD.f new file mode 100644 index 000000000..fadd6b442 --- /dev/null +++ b/mex/sources/libslicot/MB02DD.f @@ -0,0 +1,564 @@ + SUBROUTINE MB02DD( JOB, TYPET, K, M, N, TA, LDTA, T, LDT, G, + $ LDG, R, LDR, L, LDL, CS, LCS, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To update the Cholesky factor and the generator and/or the +C Cholesky factor of the inverse of a symmetric positive definite +C (s.p.d.) block Toeplitz matrix T, given the information from +C a previous factorization and additional blocks in TA of its first +C block row, or its first block column, depending on the routine +C parameter TYPET. Transformation information is stored. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the output of the routine, as follows: +C = 'R': updates the generator G of the inverse and +C computes the new columns / rows for the Cholesky +C factor R of T; +C = 'A': updates the generator G, computes the new +C columns / rows for the Cholesky factor R of T and +C the new rows / columns for the Cholesky factor L +C of the inverse; +C = 'O': only computes the new columns / rows for the +C Cholesky factor R of T. +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': the first block row of an s.p.d. block Toeplitz +C matrix was/is defined; if demanded, the Cholesky +C factors R and L are upper and lower triangular, +C respectively, and G contains the transposed +C generator of the inverse; +C = 'C': the first block column of an s.p.d. block Toeplitz +C matrix was/is defined; if demanded, the Cholesky +C factors R and L are lower and upper triangular, +C respectively, and G contains the generator of the +C inverse. This choice results in a column oriented +C algorithm which is usually faster. +C Note: in this routine, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C M (input) INTEGER +C The number of blocks in TA. M >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 0. +C +C TA (input/output) DOUBLE PRECISION array, dimension +C (LDTA,M*K) / (LDTA,K) +C On entry, the leading K-by-M*K / M*K-by-K part of this +C array must contain the (N+1)-th to (N+M)-th blocks in the +C first block row / column of an s.p.d. block Toeplitz +C matrix. +C On exit, if INFO = 0, the leading K-by-M*K / M*K-by-K part +C of this array contains information on the Householder +C transformations used, such that the array +C +C [ T TA ] / [ T ] +C [ TA ] +C +C serves as the new transformation matrix T for further +C applications of this routine. +C +C LDTA INTEGER +C The leading dimension of the array TA. +C LDTA >= MAX(1,K), if TYPET = 'R'; +C LDTA >= MAX(1,M*K), if TYPET = 'C'. +C +C T (input) DOUBLE PRECISION array, dimension (LDT,N*K) / +C (LDT,K) +C The leading K-by-N*K / N*K-by-K part of this array must +C contain transformation information generated by the SLICOT +C Library routine MB02CD, i.e., in the first K-by-K block, +C the upper / lower Cholesky factor of T(1:K,1:K), and in +C the remaining part, the Householder transformations +C applied during the initial factorization process. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K), if TYPET = 'R'; +C LDT >= MAX(1,N*K), if TYPET = 'C'. +C +C G (input/output) DOUBLE PRECISION array, dimension +C (LDG,( N + M )*K) / (LDG,2*K) +C On entry, if JOB = 'R', or 'A', then the leading +C 2*K-by-N*K / N*K-by-2*K part of this array must contain, +C in the first K-by-K block of the second block row / +C column, the lower right block of the Cholesky factor of +C the inverse of T, and in the remaining part, the generator +C of the inverse of T. +C On exit, if INFO = 0 and JOB = 'R', or 'A', then the +C leading 2*K-by-( N + M )*K / ( N + M )*K-by-2*K part of +C this array contains the same information as on entry, now +C for the updated Toeplitz matrix. Actually, to obtain a +C generator of the inverse one has to set +C G(K+1:2*K, 1:K) = 0, if TYPET = 'R'; +C G(1:K, K+1:2*K) = 0, if TYPET = 'C'. +C +C LDG INTEGER +C The leading dimension of the array G. +C LDG >= MAX(1,2*K), if TYPET = 'R' and JOB = 'R', or 'A'; +C LDG >= MAX(1,( N + M )*K), +C if TYPET = 'C' and JOB = 'R', or 'A'; +C LDG >= 1, if JOB = 'O'. +C +C R (input/output) DOUBLE PRECISION array, dimension +C (LDR,M*K) / (LDR,( N + M )*K) +C On input, the leading N*K-by-K part of R(K+1,1) / +C K-by-N*K part of R(1,K+1) contains the last block column / +C row of the previous Cholesky factor R. +C On exit, if INFO = 0, then the leading +C ( N + M )*K-by-M*K / M*K-by-( N + M )*K part of this +C array contains the last M*K columns / rows of the upper / +C lower Cholesky factor of T. The elements in the strictly +C lower / upper triangular part are not referenced. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX(1, ( N + M )*K), if TYPET = 'R'; +C LDR >= MAX(1, M*K), if TYPET = 'C'. +C +C L (output) DOUBLE PRECISION array, dimension +C (LDL,( N + M )*K) / (LDL,M*K) +C If INFO = 0 and JOB = 'A', then the leading +C M*K-by-( N + M )*K / ( N + M )*K-by-M*K part of this +C array contains the last M*K rows / columns of the lower / +C upper Cholesky factor of the inverse of T. The elements +C in the strictly upper / lower triangular part are not +C referenced. +C +C LDL INTEGER +C The leading dimension of the array L. +C LDL >= MAX(1, M*K), if TYPET = 'R' and JOB = 'A'; +C LDL >= MAX(1, ( N + M )*K), if TYPET = 'C' and JOB = 'A'; +C LDL >= 1, if JOB = 'R', or 'O'. +C +C CS (input/output) DOUBLE PRECISION array, dimension (LCS) +C On input, the leading 3*(N-1)*K part of this array must +C contain the necessary information about the hyperbolic +C rotations and Householder transformations applied +C previously by SLICOT Library routine MB02CD. +C On exit, if INFO = 0, then the leading 3*(N+M-1)*K part of +C this array contains information about all the hyperbolic +C rotations and Householder transformations applied during +C the whole process. +C +C LCS INTEGER +C The length of the array CS. LCS >= 3*(N+M-1)*K. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,(N+M-1)*K). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The block Toeplitz +C matrix associated with [ T TA ] / [ T' TA' ]' is +C not (numerically) positive definite. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 2 +C The algorithm requires 0(K ( N M + M ) ) floating point +C operations. +C +C FURTHER COMMENTS +C +C For min(K,N,M) = 0, the routine sets DWORK(1) = 1 and returns. +C Although the calculations could still be performed when N = 0, +C but min(K,M) > 0, this case is not considered as an "update". +C SLICOT Library routine MB02CD should be called with the argument +C M instead of N. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Feb. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB, TYPET + INTEGER INFO, K, LCS, LDG, LDL, LDR, LDT, LDTA, LDWORK, + $ M, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), G(LDG, *), L(LDL,*), R(LDR,*), + $ T(LDT,*), TA(LDTA,*) +C .. Local Scalars .. + INTEGER I, IERR, J, MAXWRK, STARTI, STARTR, STARTT + LOGICAL COMPG, COMPL, ISROW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLASET, DTRSM, MB02CX, MB02CY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COMPL = LSAME( JOB, 'A' ) + COMPG = LSAME( JOB, 'R' ) .OR. COMPL + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPG .OR. LSAME( JOB, 'O' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDTA.LT.1 .OR. ( ISROW .AND. LDTA.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDTA.LT.M*K ) ) THEN + INFO = -7 + ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN + INFO = -9 + ELSE IF ( ( COMPG .AND. ( ( ISROW .AND. LDG.LT.2*K ) + $ .OR. ( .NOT.ISROW .AND. LDG.LT.( N + M )*K ) ) ) + $ .OR. LDG.LT.1 ) THEN + INFO = -11 + ELSE IF ( ( ( ISROW .AND. LDR.LT.( N + M )*K ) .OR. + $ ( .NOT.ISROW .AND. LDR.LT.M*K ) ) .OR. + $ LDR.LT.1 ) THEN + INFO = -13 + ELSE IF ( ( COMPL .AND. ( ( ISROW .AND. LDL.LT.M*K ) + $ .OR. ( .NOT.ISROW .AND. LDL.LT.( N + M )*K ) ) ) + $ .OR. LDL.LT.1 ) THEN + INFO = -15 + ELSE IF ( LCS.LT.3*( N + M - 1 )*K ) THEN + INFO = -17 + ELSE IF ( LDWORK.LT.MAX( 1, ( N + M - 1 )*K ) ) THEN + DWORK(1) = MAX( 1, ( N + M - 1 )*K ) + INFO = -19 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N, M ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + MAXWRK = 1 + IF ( ISROW ) THEN +C +C Apply Cholesky factor of T(1:K, 1:K) on TA. +C + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, M*K, + $ ONE, T, LDT, TA, LDTA ) +C +C Initialize the output matrices. +C + IF ( COMPG ) THEN + CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(1,N*K+1), LDG ) + IF ( M.GE.N-1 .AND. N.GT.1 ) THEN + CALL DLACPY( 'All', K, (N-1)*K, G(K+1,K+1), LDG, + $ G(K+1,K*(M+1)+1), LDG ) + ELSE + DO 10 I = N*K, K + 1, -1 + CALL DCOPY( K, G(K+1,I), 1, G(K+1,M*K+I), 1 ) + 10 CONTINUE + END IF + CALL DLASET( 'All', K, M*K, ZERO, ZERO, G(K+1,K+1), LDG ) + END IF +C + CALL DLACPY( 'All', K, M*K, TA, LDTA, R, LDR ) +C +C Apply the stored transformations on the new columns. +C + DO 20 I = 2, N +C +C Copy the last M-1 blocks of the positive generator together; +C the last M blocks of the negative generator are contained +C in TA. +C + STARTR = ( I - 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 + CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, + $ R(STARTR,K+1), LDR ) +C +C Apply the transformations stored in T on the generator. +C + CALL MB02CY( 'Row', 'NoStructure', K, K, M*K, K, + $ R(STARTR,1), LDR, TA, LDTA, T(1,STARTR), LDT, + $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + 20 CONTINUE +C +C Now, we have "normality" and can apply further M Schur steps. +C + DO 30 I = 1, M +C +C Copy the first M-I+1 blocks of the positive generator +C together; the first M-I+1 blocks of the negative generator +C are contained in TA. +C + STARTT = 3*( N + I - 2 )*K + 1 + STARTI = ( M - I + 1 )*K + 1 + STARTR = ( N + I - 1 )*K + 1 + IF ( I.EQ.1 ) THEN + CALL DLACPY( 'All', K, (M-1)*K, R(STARTR-K,1), LDR, + $ R(STARTR,K+1), LDR ) + ELSE + CALL DLACPY( 'Upper', K, (M-I+1)*K, + $ R(STARTR-K,(I-2)*K+1), LDR, + $ R(STARTR,(I-1)*K+1), LDR ) + END IF +C +C Reduce the generator to proper form. +C + CALL MB02CX( 'Row', K, K, K, R(STARTR,(I-1)*K+1), LDR, + $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( M.GT.I ) THEN + CALL MB02CY( 'Row', 'NoStructure', K, K, (M-I)*K, K, + $ R(STARTR,I*K+1), LDR, TA(1,I*K+1), LDTA, + $ TA(1,(I-1)*K+1), LDTA, CS(STARTT), 3*K, + $ DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + IF ( COMPG ) THEN +C +C Transformations acting on the inverse generator: +C + CALL MB02CY( 'Row', 'Triangular', K, K, K, K, G(K+1,1), + $ LDG, G(1,STARTR), LDG, TA(1,(I-1)*K+1), + $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL MB02CY( 'Row', 'NoStructure', K, K, (N+I-1)*K, K, + $ G(K+1,STARTI), LDG, G, LDG, TA(1,(I-1)*K+1), + $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + IF ( COMPL ) THEN + CALL DLACPY( 'All', K, (N+I-1)*K, G(K+1,STARTI), LDG, + $ L((I-1)*K+1,1), LDL ) + CALL DLACPY( 'Lower', K, K, G(K+1,1), LDG, + $ L((I-1)*K+1,STARTR), LDL ) + END IF +C + END IF + 30 CONTINUE +C + ELSE +C +C Apply Cholesky factor of T(1:K, 1:K) on TA. +C + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M*K, K, + $ ONE, T, LDT, TA, LDTA ) +C +C Initialize the output matrices. +C + IF ( COMPG ) THEN + CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(N*K+1,1), LDG ) + IF ( M.GE.N-1 .AND. N.GT.1 ) THEN + CALL DLACPY( 'All', (N-1)*K, K, G(K+1,K+1), LDG, + $ G(K*(M+1)+1,K+1), LDG ) + ELSE + DO 40 I = 1, K + DO 35 J = N*K, K + 1, -1 + G(J+M*K,K+I) = G(J,K+I) + 35 CONTINUE + 40 CONTINUE + END IF + CALL DLASET( 'All', M*K, K, ZERO, ZERO, G(K+1,K+1), LDG ) + END IF +C + CALL DLACPY( 'All', M*K, K, TA, LDTA, R, LDR ) +C +C Apply the stored transformations on the new rows. +C + DO 50 I = 2, N +C +C Copy the last M-1 blocks of the positive generator together; +C the last M blocks of the negative generator are contained +C in TA. +C + STARTR = ( I - 1 )*K + 1 + STARTT = 3*( I - 2 )*K + 1 + CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, + $ R(K+1,STARTR), LDR ) +C +C Apply the transformations stored in T on the generator. +C + CALL MB02CY( 'Column', 'NoStructure', K, K, M*K, K, + $ R(1,STARTR), LDR, TA, LDTA, T(STARTR,1), LDT, + $ CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + 50 CONTINUE +C +C Now, we have "normality" and can apply further M Schur steps. +C + DO 60 I = 1, M +C +C Copy the first M-I+1 blocks of the positive generator +C together; the first M-I+1 blocks of the negative generator +C are contained in TA. +C + STARTT = 3*( N + I - 2 )*K + 1 + STARTI = ( M - I + 1 )*K + 1 + STARTR = ( N + I - 1 )*K + 1 + IF ( I.EQ.1 ) THEN + CALL DLACPY( 'All', (M-1)*K, K, R(1,STARTR-K), LDR, + $ R(K+1,STARTR), LDR ) + ELSE + CALL DLACPY( 'Lower', (M-I+1)*K, K, + $ R((I-2)*K+1,STARTR-K), LDR, + $ R((I-1)*K+1,STARTR), LDR ) + END IF +C +C Reduce the generator to proper form. +C + CALL MB02CX( 'Column', K, K, K, R((I-1)*K+1,STARTR), LDR, + $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, DWORK, + $ LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + IF ( M.GT.I ) THEN + CALL MB02CY( 'Column', 'NoStructure', K, K, (M-I)*K, K, + $ R(I*K+1,STARTR), LDR, TA(I*K+1,1), LDTA, + $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, + $ DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C + IF ( COMPG ) THEN +C +C Transformations acting on the inverse generator: +C + CALL MB02CY( 'Column', 'Triangular', K, K, K, K, + $ G(1,K+1), LDG, G(STARTR,1), LDG, + $ TA((I-1)*K+1,1), LDTA, CS(STARTT), 3*K, + $ DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + CALL MB02CY( 'Column', 'NoStructure', K, K, (N+I-1)*K, K, + $ G(STARTI,K+1), LDG, G, LDG, TA((I-1)*K+1,1), + $ LDTA, CS(STARTT), 3*K, DWORK, LDWORK, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) +C + IF ( COMPL ) THEN + CALL DLACPY( 'All', (N+I-1)*K, K, G(STARTI,K+1), LDG, + $ L(1,(I-1)*K+1), LDL ) + CALL DLACPY( 'Upper', K, K, G(1,K+1), LDG, + $ L(STARTR,(I-1)*K+1), LDL ) + END IF +C + END IF + 60 CONTINUE +C + END IF +C + DWORK(1) = MAXWRK +C + RETURN +C +C *** Last line of MB02DD *** + END diff --git a/mex/sources/libslicot/MB02ED.f b/mex/sources/libslicot/MB02ED.f new file mode 100644 index 000000000..d5c366cbc --- /dev/null +++ b/mex/sources/libslicot/MB02ED.f @@ -0,0 +1,445 @@ + SUBROUTINE MB02ED( TYPET, K, N, NRHS, T, LDT, B, LDB, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of linear equations T*X = B or X*T = B with +C a symmetric positive definite (s.p.d.) block Toeplitz matrix T. +C T is defined either by its first block row or its first block +C column, depending on the parameter TYPET. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': T contains the first block row of an s.p.d. block +C Toeplitz matrix, and the system X*T = B is solved; +C = 'C': T contains the first block column of an s.p.d. +C block Toeplitz matrix, and the system T*X = B is +C solved. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides. NRHS >= 0. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N*K) / (LDT,K) +C On entry, the leading K-by-N*K / N*K-by-K part of this +C array must contain the first block row / column of an +C s.p.d. block Toeplitz matrix. +C On exit, if INFO = 0 and NRHS > 0, then the leading +C K-by-N*K / N*K-by-K part of this array contains the last +C row / column of the Cholesky factor of inv(T). +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K), if TYPET = 'R'; +C LDT >= MAX(1,N*K), if TYPET = 'C'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,N*K) / (LDB,NRHS) +C On entry, the leading NRHS-by-N*K / N*K-by-NRHS part of +C this array must contain the right hand side matrix B. +C On exit, the leading NRHS-by-N*K / N*K-by-NRHS part of +C this array contains the solution matrix X. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,NRHS), if TYPET = 'R'; +C LDB >= MAX(1,N*K), if TYPET = 'C'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -10, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,N*K*K+(N+2)*K). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The Toeplitz matrix +C associated with T is not (numerically) positive +C definite. +C +C METHOD +C +C Householder transformations, modified hyperbolic rotations and +C block Gaussian eliminations are used in the Schur algorithm [1], +C [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically equivalent with forming +C the Cholesky factor R and the inverse Cholesky factor of T, using +C the generalized Schur algorithm, and solving the systems of +C equations R*X = L*B or X*R = B*L by a blocked backward +C substitution algorithm. +C 3 2 2 2 +C The algorithm requires 0(K N + K N NRHS) floating point +C operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Chemnitz, Germany, December 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C February 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPET + INTEGER INFO, K, LDB, LDT, LDWORK, N, NRHS +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), DWORK(*), T(LDT,*) +C .. Local Scalars .. + INTEGER I, IERR, MAXWRK, STARTH, STARTI, STARTN, + $ STARTR, STARTT + LOGICAL ISROW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DPOTRF, DTRMM, DTRSM, + $ MB02CX, MB02CY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.N*K ) ) THEN + INFO = -6 + ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.NRHS ) .OR. + $ ( .NOT.ISROW .AND. LDB.LT.N*K ) ) THEN + INFO = -8 + ELSE IF ( LDWORK.LT.MAX( 1, N*K*K + ( N + 2 )*K ) ) THEN + DWORK(1) = MAX( 1, N*K*K + ( N + 2 )*K ) + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N, NRHS ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + MAXWRK = 0 + STARTN = 1 + STARTT = N*K*K + 1 + STARTH = STARTT + 3*K +C + IF ( ISROW ) THEN +C +C T is the first block row of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Upper', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, + $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) +C +C Initialize the generator, do the first Schur step and set +C B = -B. +C T contains the nonzero blocks of the positive parts in the +C generator and the inverse generator. +C DWORK(STARTN) contains the nonzero blocks of the negative parts +C in the generator and the inverse generator. +C + CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', NRHS, + $ K, ONE, T, LDT, B, LDB ) + IF ( N.GT.1 ) + $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (N-1)*K, + $ K, ONE, B, LDB, T(1,K+1), LDT, -ONE, B(1,K+1), + $ LDB ) +C + CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), K ) + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, K, + $ ONE, T, LDT, DWORK(STARTN), K ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'All', K, (N-1)*K, T(1,K+1), LDT, + $ DWORK(STARTN+K*K), K ) + CALL DLACPY( 'All', K, K, DWORK(STARTN), K, T(1,(N-1)*K+1), + $ LDT ) +C + CALL DTRMM ( 'Right', 'Lower', 'NonTranspose', 'NonUnit', NRHS, + $ K, ONE, T(1,(N-1)*K+1), LDT, B, LDB ) +C +C Processing the generator. +C + DO 10 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTI = ( N - I )*K + 1 +C +C Transform the generator of T to proper form. +C + CALL MB02CX( 'Row', K, K, K, T, LDT, + $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, + $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) + CALL MB02CY( 'Row', 'NoStructure', K, K, (N-I)*K, K, + $ T(1,K+1), LDT, DWORK(STARTN+I*K*K), K, + $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), + $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Block Gaussian eliminates the i-th block in B. +C + CALL DTRSM( 'Right', 'Upper', 'NonTranspose', 'NonUnit', + $ NRHS, K, -ONE, T, LDT, B(1,STARTR), LDB ) + IF ( N.GT.I ) + $ CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, + $ (N-I)*K, K, ONE, B(1,STARTR), LDB, T(1,K+1), + $ LDT, ONE, B(1,STARTR+K), LDB ) +C +C Apply hyperbolic transformations on the negative generator. +C + CALL DLASET( 'All', K, K, ZERO, ZERO, T(1,STARTI), LDT ) + CALL MB02CY( 'Row', 'NoStructure', K, K, (I-1)*K, K, + $ T(1,STARTI), LDT, DWORK(STARTN), K, + $ DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), 3*K, + $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Note that DWORK(STARTN+(I-1)*K*K) serves simultaneously +C as the transformation container as well as the new block in +C the negative generator. +C + CALL MB02CY( 'Row', 'Triangular', K, K, K, K, + $ T(1,(N-1)*K+1), LDT, DWORK(STARTN+(I-1)*K*K), + $ K, DWORK(STARTN+(I-1)*K*K), K, DWORK(STARTT), + $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Finally the Gaussian elimination is applied on the inverse +C generator. +C + CALL DGEMM( 'NonTranspose', 'NonTranspose', NRHS, (I-1)*K, + $ K, ONE, B(1,STARTR), LDB, T(1,STARTI), LDT, ONE, + $ B, LDB ) + CALL DTRMM( 'Right', 'Lower', 'NonTranspose', 'NonUnit', + $ NRHS, K, ONE, T(1,(N-1)*K+1), LDT, B(1,STARTR), + $ LDB ) + 10 CONTINUE +C + ELSE +C +C T is the first block column of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Lower', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', + $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) +C +C Initialize the generator, do the first Schur step and set +C B = -B. +C T contains the nonzero blocks of the positive parts in the +C generator and the inverse generator. +C DWORK(STARTN) contains the nonzero blocks of the negative parts +C in the generator and the inverse generator. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, + $ NRHS, ONE, T, LDT, B, LDB ) + IF ( N.GT.1 ) + $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-1)*K, NRHS, + $ K, ONE, T(K+1,1), LDT, B, LDB, -ONE, B(K+1,1), + $ LDB ) +C + CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(STARTN), N*K ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', K, K, + $ ONE, T, LDT, DWORK(STARTN), N*K ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'All', (N-1)*K, K, T(K+1,1), LDT, + $ DWORK(STARTN+K), N*K ) + CALL DLACPY( 'All', K, K, DWORK(STARTN), N*K, T((N-1)*K+1,1), + $ LDT ) +C + CALL DTRMM ( 'Left', 'Upper', 'NonTranspose', 'NonUnit', K, + $ NRHS, ONE, T((N-1)*K+1,1), LDT, B, LDB ) +C +C Processing the generator. +C + DO 20 I = 2, N + STARTR = ( I - 1 )*K + 1 + STARTI = ( N - I )*K + 1 +C +C Transform the generator of T to proper form. +C + CALL MB02CX( 'Column', K, K, K, T, LDT, + $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, + $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) + CALL MB02CY( 'Column', 'NoStructure', K, K, (N-I)*K, K, + $ T(K+1,1), LDT, DWORK(STARTN+I*K), N*K, + $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), + $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Block Gaussian eliminates the i-th block in B. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', K, + $ NRHS, -ONE, T, LDT, B(STARTR,1), LDB ) + IF ( N.GT.I ) + $ CALL DGEMM( 'NonTranspose', 'NonTranspose', (N-I)*K, + $ NRHS, K, ONE, T(K+1,1), LDT, B(STARTR,1), + $ LDB, ONE, B(STARTR+K,1), LDB ) +C +C Apply hyperbolic transformations on the negative generator. +C + CALL DLASET( 'All', K, K, ZERO, ZERO, T(STARTI,1), LDT ) + CALL MB02CY( 'Column', 'NoStructure', K, K, (I-1)*K, K, + $ T(STARTI,1), LDT, DWORK(STARTN), N*K, + $ DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), 3*K, + $ DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Note that DWORK(STARTN+(I-1)*K) serves simultaneously +C as the transformation container as well as the new block in +C the negative generator. +C + CALL MB02CY( 'Column', 'Triangular', K, K, K, K, + $ T((N-1)*K+1,1), LDT, DWORK(STARTN+(I-1)*K), + $ N*K, DWORK(STARTN+(I-1)*K), N*K, DWORK(STARTT), + $ 3*K, DWORK(STARTH), LDWORK-STARTH+1, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(STARTH) ) ) +C +C Finally the Gaussian elimination is applied on the inverse +C generator. +C + CALL DGEMM( 'NonTranspose', 'NonTranspose', (I-1)*K, NRHS, + $ K, ONE, T(STARTI,1), LDT, B(STARTR,1), LDB, ONE, + $ B, LDB ) + CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', + $ K, NRHS, ONE, T((N-1)*K+1,1), LDT, B(STARTR,1), + $ LDB ) +C + 20 CONTINUE +C + END IF +C + DWORK(1) = MAX( 1, STARTH - 1 + MAXWRK ) +C + RETURN +C +C *** Last line of MB02ED *** + END diff --git a/mex/sources/libslicot/MB02FD.f b/mex/sources/libslicot/MB02FD.f new file mode 100644 index 000000000..0e608a832 --- /dev/null +++ b/mex/sources/libslicot/MB02FD.f @@ -0,0 +1,383 @@ + SUBROUTINE MB02FD( TYPET, K, N, P, S, T, LDT, R, LDR, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the incomplete Cholesky (ICC) factor of a symmetric +C positive definite (s.p.d.) block Toeplitz matrix T, defined by +C either its first block row, or its first block column, depending +C on the routine parameter TYPET. +C +C By subsequent calls of this routine, further rows / columns of +C the Cholesky factor can be added. +C Furthermore, the generator of the Schur complement of the leading +C (P+S)*K-by-(P+S)*K block in T is available, which can be used, +C e.g., for measuring the quality of the ICC factorization. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': T contains the first block row of an s.p.d. block +C Toeplitz matrix; the ICC factor R is upper +C trapezoidal; +C = 'C': T contains the first block column of an s.p.d. +C block Toeplitz matrix; the ICC factor R is lower +C trapezoidal; this choice leads to better +C localized memory references and hence a faster +C algorithm. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 0. +C +C P (input) INTEGER +C The number of previously computed block rows / columns +C of R. 0 <= P <= N. +C +C S (input) INTEGER +C The number of block rows / columns of R to compute. +C 0 <= S <= N-P. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,(N-P)*K) / (LDT,K) +C On entry, if P = 0, then the leading K-by-N*K / N*K-by-K +C part of this array must contain the first block row / +C column of an s.p.d. block Toeplitz matrix. +C If P > 0, the leading K-by-(N-P)*K / (N-P)*K-by-K must +C contain the negative generator of the Schur complement of +C the leading P*K-by-P*K part in T, computed from previous +C calls of this routine. +C On exit, if INFO = 0, then the leading K-by-(N-P)*K / +C (N-P)*K-by-K part of this array contains, in the first +C K-by-K block, the upper / lower Cholesky factor of +C T(1:K,1:K), in the following S-1 K-by-K blocks, the +C Householder transformations applied during the process, +C and in the remaining part, the negative generator of the +C Schur complement of the leading (P+S)*K-by(P+S)*K part +C in T. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K), if TYPET = 'R'; +C LDT >= MAX(1,(N-P)*K), if TYPET = 'C'. +C +C R (input/output) DOUBLE PRECISION array, dimension +C (LDR, N*K) / (LDR, S*K ) if P = 0; +C (LDR, (N-P+1)*K) / (LDR, (S+1)*K ) if P > 0. +C On entry, if P > 0, then the leading K-by-(N-P+1)*K / +C (N-P+1)*K-by-K part of this array must contain the +C nonzero blocks of the last block row / column in the +C ICC factor from a previous call of this routine. Note that +C this part is identical with the positive generator of +C the Schur complement of the leading P*K-by-P*K part in T. +C If P = 0, then R is only an output parameter. +C On exit, if INFO = 0 and P = 0, then the leading +C S*K-by-N*K / N*K-by-S*K part of this array contains the +C upper / lower trapezoidal ICC factor. +C On exit, if INFO = 0 and P > 0, then the leading +C (S+1)*K-by-(N-P+1)*K / (N-P+1)*K-by-(S+1)*K part of this +C array contains the upper / lower trapezoidal part of the +C P-th to (P+S)-th block rows / columns of the ICC factor. +C The elements in the strictly lower / upper trapezoidal +C part are not referenced. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX(1, S*K ), if TYPET = 'R' and P = 0; +C LDR >= MAX(1, (S+1)*K ), if TYPET = 'R' and P > 0; +C LDR >= MAX(1, N*K ), if TYPET = 'C' and P = 0; +C LDR >= MAX(1, (N-P+1)*K ), if TYPET = 'C' and P > 0. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -11, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,(N+1)*K,4*K), if P = 0; +C LDWORK >= MAX(1,(N-P+2)*K,4*K), if P > 0. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed; the Toeplitz matrix +C associated with T is not (numerically) positive +C definite in its leading (P+S)*K-by-(P+S)*K part. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 +C The algorithm requires 0(K S (N-P)) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, April 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, +C Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TYPET + INTEGER INFO, K, LDR, LDT, LDWORK, N, P, S +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), R(LDR,*), T(LDT,*) +C .. Local Scalars .. + INTEGER COUNTR, I, IERR, MAXWRK, ST, STARTR + LOGICAL ISROW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DPOTRF, DTRSM, MB02CX, MB02CY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + ISROW = LSAME( TYPET, 'R' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN + INFO = -4 + ELSE IF ( S.LT.0 .OR. S.GT.( N-P ) ) THEN + INFO = -5 + ELSE IF ( LDT.LT.1 .OR. ( ISROW .AND. LDT.LT.K ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.( N-P )*K ) ) THEN + INFO = -7 + ELSE IF ( LDR.LT.1 .OR. + $ ( ISROW .AND. P.EQ.0 .AND. ( LDR.LT.S*K ) ) .OR. + $ ( ISROW .AND. P.GT.0 .AND. ( LDR.LT.( S+1 )*K ) ) .OR. + $ ( .NOT.ISROW .AND. P.EQ.0 .AND. ( LDR.LT.N*K ) ) .OR. + $ ( .NOT.ISROW .AND. P.GT.0 .AND. ( LDR.LT.( N-P+1 )*K ) ) ) THEN + INFO = -9 + ELSE + IF ( P.EQ.0 ) THEN + COUNTR = ( N + 1 )*K + ELSE + COUNTR = ( N - P + 2 )*K + END IF + COUNTR = MAX( COUNTR, 4*K ) + IF ( LDWORK.LT.MAX( 1, COUNTR ) ) THEN + DWORK(1) = MAX( 1, COUNTR ) + INFO = -11 + END IF + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, N, S ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + MAXWRK = 1 +C + IF ( ISROW ) THEN +C + IF ( P.EQ.0 ) THEN +C +C T is the first block row of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Upper', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, + $ (N-1)*K, ONE, T, LDT, T(1,K+1), LDT ) + CALL DLACPY( 'Upper', K, N*K, T, LDT, R, LDR ) +C + IF ( S.EQ.1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ST = 2 + COUNTR = ( N - 1 )*K + ELSE + ST = 1 + COUNTR = ( N - P )*K + END IF +C + STARTR = 1 +C + DO 10 I = ST, S + CALL DLACPY( 'Upper', K, COUNTR, R(STARTR,STARTR), LDR, + $ R(STARTR+K,STARTR+K), LDR ) + STARTR = STARTR + K + COUNTR = COUNTR - K + CALL MB02CX( 'Row', K, K, K, R(STARTR,STARTR), LDR, + $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), + $ LDWORK-3*K, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) + CALL MB02CY( 'Row', 'NoStructure', K, K, COUNTR, K, + $ R(STARTR,STARTR+K), LDR, T(1,STARTR+K), LDT, + $ T(1,STARTR), LDT, DWORK, 3*K, DWORK(3*K+1), + $ LDWORK-3*K, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) + 10 CONTINUE +C + ELSE +C + IF ( P.EQ.0 ) THEN +C +C T is the first block column of a block Toeplitz matrix. +C Bring T to proper form by triangularizing its first block. +C + CALL DPOTRF( 'Lower', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + IF ( N.GT.1 ) + $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', + $ (N-1)*K, K, ONE, T, LDT, T(K+1,1), LDT ) + CALL DLACPY( 'Lower', N*K, K, T, LDT, R, LDR ) +C + IF ( S.EQ.1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ST = 2 + COUNTR = ( N - 1 )*K + ELSE + ST = 1 + COUNTR = ( N - P )*K + END IF +C + STARTR = 1 +C + DO 20 I = ST, S + CALL DLACPY( 'Lower', COUNTR, K, R(STARTR,STARTR), LDR, + $ R(STARTR+K,STARTR+K), LDR ) + STARTR = STARTR + K + COUNTR = COUNTR - K + CALL MB02CX( 'Column', K, K, K, R(STARTR,STARTR), LDR, + $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), + $ LDWORK-3*K, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF +C + MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) + CALL MB02CY( 'Column', 'NoStructure', K, K, COUNTR, K, + $ R(STARTR+K,STARTR), LDR, T(STARTR+K,1), LDT, + $ T(STARTR,1), LDT, DWORK, 3*K, DWORK(3*K+1), + $ LDWORK-3*K, IERR ) + MAXWRK = MAX( MAXWRK, INT( DWORK(3*K+1) ) + 3*K ) + 20 CONTINUE +C + END IF +C + DWORK(1) = MAXWRK +C + RETURN +C +C *** Last line of MB02FD *** + END diff --git a/mex/sources/libslicot/MB02GD.f b/mex/sources/libslicot/MB02GD.f new file mode 100644 index 000000000..c227a556a --- /dev/null +++ b/mex/sources/libslicot/MB02GD.f @@ -0,0 +1,558 @@ + SUBROUTINE MB02GD( TYPET, TRIU, K, N, NL, P, S, T, LDT, RB, LDRB, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor of a banded symmetric positive +C definite (s.p.d.) block Toeplitz matrix, defined by either its +C first block row, or its first block column, depending on the +C routine parameter TYPET. +C +C By subsequent calls of this routine the Cholesky factor can be +C computed block column by block column. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYPET CHARACTER*1 +C Specifies the type of T, as follows: +C = 'R': T contains the first block row of an s.p.d. block +C Toeplitz matrix; the Cholesky factor is upper +C triangular; +C = 'C': T contains the first block column of an s.p.d. +C block Toeplitz matrix; the Cholesky factor is +C lower triangular. This choice results in a column +C oriented algorithm which is usually faster. +C Note: in the sequel, the notation x / y means that +C x corresponds to TYPET = 'R' and y corresponds to +C TYPET = 'C'. +C +C TRIU CHARACTER*1 +C Specifies the structure of the last block in T, as +C follows: +C = 'N': the last block has no special structure; +C = 'T': the last block is lower / upper triangular. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows / columns in T, which should be equal +C to the blocksize. K >= 0. +C +C N (input) INTEGER +C The number of blocks in T. N >= 1. +C If TRIU = 'N', N >= 1; +C if TRIU = 'T', N >= 2. +C +C NL (input) INTEGER +C The lower block bandwidth, i.e., NL + 1 is the number of +C nonzero blocks in the first block column of the block +C Toeplitz matrix. +C If TRIU = 'N', 0 <= NL < N; +C if TRIU = 'T', 1 <= NL < N. +C +C P (input) INTEGER +C The number of previously computed block rows / columns of +C the Cholesky factor. 0 <= P <= N. +C +C S (input) INTEGER +C The number of block rows / columns of the Cholesky factor +C to compute. 0 <= S <= N - P. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,(NL+1)*K) / (LDT,K) +C On entry, if P = 0, the leading K-by-(NL+1)*K / +C (NL+1)*K-by-K part of this array must contain the first +C block row / column of an s.p.d. block Toeplitz matrix. +C On entry, if P > 0, the leading K-by-(NL+1)*K / +C (NL+1)*K-by-K part of this array must contain the P-th +C block row / column of the Cholesky factor. +C On exit, if INFO = 0, then the leading K-by-(NL+1)*K / +C (NL+1)*K-by-K part of this array contains the (P+S)-th +C block row / column of the Cholesky factor. +C +C LDT INTEGER +C The leading dimension of the array T. +C LDT >= MAX(1,K) / MAX(1,(NL+1)*K). +C +C RB (input/output) DOUBLE PRECISION array, dimension +C (LDRB,MIN(P+NL+S,N)*K) / (LDRB,MIN(P+S,N)*K) +C On entry, if TYPET = 'R' and TRIU = 'N' and P > 0, +C the leading (NL+1)*K-by-MIN(NL,N-P)*K part of this array +C must contain the (P*K+1)-st to ((P+NL)*K)-th columns +C of the upper Cholesky factor in banded format from a +C previous call of this routine. +C On entry, if TYPET = 'R' and TRIU = 'T' and P > 0, +C the leading (NL*K+1)-by-MIN(NL,N-P)*K part of this array +C must contain the (P*K+1)-st to (MIN(P+NL,N)*K)-th columns +C of the upper Cholesky factor in banded format from a +C previous call of this routine. +C On exit, if TYPET = 'R' and TRIU = 'N', the leading +C (NL+1)*K-by-MIN(NL+S,N-P)*K part of this array contains +C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the +C upper Cholesky factor in banded format. +C On exit, if TYPET = 'R' and TRIU = 'T', the leading +C (NL*K+1)-by-MIN(NL+S,N-P)*K part of this array contains +C the (P*K+1)-st to (MIN(P+NL+S,N)*K)-th columns of the +C upper Cholesky factor in banded format. +C On exit, if TYPET = 'C' and TRIU = 'N', the leading +C (NL+1)*K-by-MIN(S,N-P)*K part of this array contains +C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower +C Cholesky factor in banded format. +C On exit, if TYPET = 'C' and TRIU = 'T', the leading +C (NL*K+1)-by-MIN(S,N-P)*K part of this array contains +C the (P*K+1)-st to (MIN(P+S,N)*K)-th columns of the lower +C Cholesky factor in banded format. +C For further details regarding the band storage scheme see +C the documentation of the LAPACK routine DPBTF2. +C +C LDRB INTEGER +C The leading dimension of the array RB. +C If TRIU = 'N', LDRB >= MAX( (NL+1)*K,1 ); +C if TRIU = 'T', LDRB >= NL*K+1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -13, DWORK(1) returns the minimum +C value of LDWORK. +C The first 1 + ( NL + 1 )*K*K elements of DWORK should be +C preserved during successive calls of the routine. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1 + ( NL + 1 )*K*K + NL*K. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The Toeplitz matrix +C associated with T is not (numerically) positive +C definite. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C 3 +C The algorithm requires O( K *N*NL ) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRIU, TYPET + INTEGER INFO, K, LDRB, LDT, LDWORK, N, NL, P, S +C .. Array Arguments .. + DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), T(LDT,*) +C .. Local Scalars .. + CHARACTER STRUCT + LOGICAL ISROW, LTRI + INTEGER HEAD, I, IERR, J, JJ, KK, LEN, LEN2, LENR, NB, + $ NBMIN, PDW, POSR, PRE, RNK, SIZR, STPS, WRKMIN, + $ WRKOPT +C .. Local Arrays .. + INTEGER IPVT(1) + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLASET, DPOTRF, DTRSM, MB02CU, + $ MB02CV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN, MOD +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LTRI = LSAME( TRIU, 'T' ) + LENR = ( NL + 1 )*K + IF ( LTRI ) THEN + SIZR = NL*K + 1 + ELSE + SIZR = LENR + END IF + ISROW = LSAME( TYPET, 'R' ) + WRKMIN = 1 + ( LENR + NL )*K +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( ( LTRI .AND. N.LT.2 ) .OR. + $ ( .NOT.LTRI .AND. N.LT.1 ) ) THEN + INFO = -4 + ELSE IF ( NL.GE.N .OR. ( LTRI .AND. NL.LT.1 ) .OR. + $ ( .NOT.LTRI .AND. NL.LT.0 ) ) THEN + INFO = -5 + ELSE IF ( P.LT.0 .OR. P.GT.N ) THEN + INFO = -6 + ELSE IF ( S.LT.0 .OR. S.GT.N-P ) THEN + INFO = -7 + ELSE IF ( ( ISROW .AND. LDT.LT.MAX( 1, K ) ) .OR. + $ ( .NOT.ISROW .AND. LDT.LT.MAX( 1, LENR ) ) ) + $ THEN + INFO = -9 + ELSE IF ( ( LTRI .AND. LDRB.LT.SIZR ) .OR. + $ ( .NOT.LTRI .AND. LDRB.LT.MAX( 1, LENR ) ) ) + $ THEN + INFO = -11 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -13 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02GD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( S*K.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Compute the generator if P = 0. +C + IF ( P.EQ.0 ) THEN + IF ( ISROW ) THEN + CALL DPOTRF( 'Upper', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF + IF ( NL.GT.0 ) + $ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'NonUnit', K, + $ NL*K, ONE, T, LDT, T(1,K+1), LDT ) +C +C Copy the first block row to RB. +C + IF ( LTRI ) THEN +C + DO 10 I = 1, LENR - K + CALL DCOPY( MIN( I, K ), T(1,I), 1, + $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) + 10 CONTINUE +C + DO 20 I = K, 1, -1 + CALL DCOPY( I, T(K-I+1,LENR-I+1), 1, + $ RB( 1,LENR-I+1 ), 1 ) + 20 CONTINUE +C + ELSE +C + DO 30 I = 1, LENR + CALL DCOPY( MIN( I, K ), T(1,I), 1, + $ RB( MAX( SIZR-I+1, 1 ),I ), 1 ) + 30 CONTINUE +C + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + CALL DLACPY( 'All', K, NL*K, T(1,K+1), LDT, DWORK(2), K ) + CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K*K+2), K ) + POSR = K + 1 + ELSE + CALL DPOTRF( 'Lower', K, T, LDT, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The matrix is not positive definite. +C + INFO = 1 + RETURN + END IF + IF ( NL.GT.0 ) + $ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', + $ NL*K, K, ONE, T, LDT, T(K+1,1), LDT ) +C +C Copy the first block column to RB. +C + POSR = 1 + IF ( LTRI ) THEN +C + DO 40 I = 1, K + CALL DCOPY( SIZR, T(I,I), 1, RB(1,POSR), 1 ) + POSR = POSR + 1 + 40 CONTINUE +C + ELSE +C + DO 50 I = 1, K + CALL DCOPY( LENR-I+1, T(I,I), 1, RB(1,POSR), 1 ) + IF ( LENR.LT.N*K .AND. I.GT.1 ) THEN + CALL DLASET( 'All', I-1, 1, ZERO, ZERO, + $ RB(LENR-I+2,POSR), LDRB ) + END IF + POSR = POSR + 1 + 50 CONTINUE +C + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + CALL DLACPY( 'All', NL*K, K, T(K+1,1), LDT, DWORK(2), LENR ) + CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(NL*K+2), LENR ) + END IF + PRE = 1 + STPS = S - 1 + ELSE + PRE = P + STPS = S + POSR = 1 + END IF +C + PDW = LENR*K + 1 + HEAD = MOD( ( PRE - 1 )*K, LENR ) +C +C Determine block size for the involved block Householder +C transformations. +C + IF ( ISROW ) THEN + NB = MIN( ILAENV( 1, 'DGEQRF', ' ', K, LENR, -1, -1 ), K ) + ELSE + NB = MIN( ILAENV( 1, 'DGELQF', ' ', LENR, K, -1, -1 ), K ) + END IF + KK = PDW + 4*K + WRKOPT = KK + LENR*NB + KK = LDWORK - KK + IF ( KK.LT.LENR*NB ) NB = KK / LENR + IF ( ISROW ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', K, LENR, -1, -1 ) ) + ELSE + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, K, -1, -1 ) ) + END IF + IF ( NB.LT.NBMIN ) NB = 0 +C +C Generator reduction process. +C + IF ( ISROW ) THEN +C + DO 90 I = PRE, PRE + STPS - 1 + CALL MB02CU( 'Row', K, K, K, NB, T, LDT, DUM, 1, + $ DWORK(HEAD*K+2), K, RNK, IPVT, DWORK(PDW+1), + $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The positive definiteness is (numerically) +C not satisfied. +C + INFO = 1 + RETURN + END IF +C + LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) + LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) + IF ( LEN.EQ.( LENR-K ) ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Row', STRUCT, K, LEN, K, K, NB, -1, DUM, 1, + $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+1), LDT, + $ DUM, 1, DWORK((HEAD+K)*K+2), K, DWORK(PDW+1), + $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + IF ( ( N - I )*K.GE.LENR ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Row', STRUCT, K, LEN2, K, K, NB, -1, DUM, 1, + $ DUM, 1, DWORK(HEAD*K+2), K, T(1,K+LEN+1), LDT, + $ DUM, 1, DWORK(2), K, DWORK(PDW+1), + $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD*K+2), K ) +C +C Copy current block row to RB. +C + IF ( LTRI ) THEN +C + DO 60 J = 1, MIN( LEN + LEN2 + K, LENR - K ) + CALL DCOPY( MIN( J, K ), T(1,J), 1, + $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1 ), 1 ) + 60 CONTINUE +C + IF ( LEN+LEN2+K.GE.LENR ) THEN +C + DO 70 JJ = K, 1, -1 + CALL DCOPY( JJ, T(K-JJ+1,LENR-JJ+1), 1, + $ RB(1,POSR+LENR-JJ), 1 ) + 70 CONTINUE +C + END IF + POSR = POSR + K +C + ELSE +C + DO 80 J = 1, LEN + LEN2 + K + CALL DCOPY( MIN( J, K ), T(1,J), 1, + $ RB(MAX( SIZR-J+1, 1 ),POSR+J-1), 1 ) + IF ( J.GT.LENR-K ) THEN + CALL DLASET( 'All', SIZR-J, 1, ZERO, ZERO, + $ RB(1,POSR+J-1), 1 ) + END IF + 80 CONTINUE +C + POSR = POSR + K + END IF + HEAD = MOD( HEAD + K, LENR ) + 90 CONTINUE +C + ELSE +C + DO 120 I = PRE, PRE + STPS - 1 +C + CALL MB02CU( 'Column', K, K, K, NB, T, LDT, DUM, 1, + $ DWORK(HEAD+2), LENR, RNK, IPVT, DWORK(PDW+1), + $ ZERO, DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + IF ( IERR.NE.0 ) THEN +C +C Error return: The positive definiteness is (numerically) +C not satisfied. +C + INFO = 1 + RETURN + END IF +C + LEN = MAX( MIN( ( N - I )*K - K, LENR - HEAD - K ), 0 ) + LEN2 = MAX( MIN( ( N - I )*K - LEN - K, HEAD ), 0 ) + IF ( LEN.EQ.( LENR-K ) ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Column', STRUCT, K, LEN, K, K, NB, -1, DUM, + $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+1,1), LDT, + $ DUM, 1, DWORK(HEAD+K+2), LENR, DWORK(PDW+1), + $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + IF ( ( N - I )*K.GE.LENR ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Column', STRUCT, K, LEN2, K, K, NB, -1, DUM, + $ 1, DUM, 1, DWORK(HEAD+2), LENR, T(K+LEN+1,1), + $ LDT, DUM, 1, DWORK(2), LENR, DWORK(PDW+1), + $ DWORK(PDW+4*K+1), LDWORK-PDW-4*K, IERR ) +C + CALL DLASET( 'All', K, K, ZERO, ZERO, DWORK(HEAD+2), LENR ) +C +C Copy current block column to RB. +C + IF ( LTRI ) THEN +C + DO 100 J = 1, K + CALL DCOPY( MIN( SIZR, (N-I)*K-J+1 ), T(J,J), 1, + $ RB(1,POSR), 1 ) + POSR = POSR + 1 + 100 CONTINUE +C + ELSE +C + DO 110 J = 1, K + CALL DCOPY( MIN( SIZR-J+1, (N-I)*K-J+1 ), T(J,J), 1, + $ RB(1,POSR), 1 ) + IF ( LENR.LT.(N-I)*K ) THEN + CALL DLASET( 'All', J-1, 1, ZERO, ZERO, + $ RB(MIN( SIZR-J+1, (N-I)*K-J+1 ) + 1, + $ POSR), LDRB ) + END IF + POSR = POSR + 1 + 110 CONTINUE +C + END IF + HEAD = MOD( HEAD + K, LENR ) + 120 CONTINUE +C + END IF + DWORK(1) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of MB02GD *** + END diff --git a/mex/sources/libslicot/MB02HD.f b/mex/sources/libslicot/MB02HD.f new file mode 100644 index 000000000..c93d2474a --- /dev/null +++ b/mex/sources/libslicot/MB02HD.f @@ -0,0 +1,545 @@ + SUBROUTINE MB02HD( TRIU, K, L, M, ML, N, NU, P, S, TC, LDTC, TR, + $ LDTR, RB, LDRB, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a banded K*M-by-L*N block Toeplitz matrix T with +C block size (K,L), specified by the nonzero blocks of its first +C block column TC and row TR, a LOWER triangular matrix R (in band +C storage scheme) such that +C T T +C T T = R R . (1) +C +C It is assumed that the first MIN(M*K, N*L) columns of T are +C linearly independent. +C +C By subsequent calls of this routine, the matrix R can be computed +C block column by block column. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRIU CHARACTER*1 +C Specifies the structure, if any, of the last blocks in TC +C and TR, as follows: +C = 'N': TC and TR have no special structure; +C = 'T': TC and TR are upper and lower triangular, +C respectively. Depending on the block sizes, two +C different shapes of the last blocks in TC and TR +C are possible, as illustrated below: +C +C 1) TC TR 2) TC TR +C +C x x x x 0 0 x x x x x 0 0 0 +C 0 x x x x 0 0 x x x x x 0 0 +C 0 0 x x x x 0 0 x x x x x 0 +C 0 0 0 x x x +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in the blocks of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in the blocks of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in the first block column of T. +C M >= 1. +C +C ML (input) INTEGER +C The lower block bandwidth, i.e., ML + 1 is the number of +C nonzero blocks in the first block column of T. +C 0 <= ML < M and (ML + 1)*K >= L and +C if ( M*K <= N*L ), ML >= M - INT( ( M*K - 1 )/L ) - 1; +C ML >= M - INT( M*K/L ) or +C MOD( M*K, L ) >= K; +C if ( M*K >= N*L ), ML*K >= N*( L - K ). +C +C N (input) INTEGER +C The number of blocks in the first block row of T. +C N >= 1. +C +C NU (input) INTEGER +C The upper block bandwidth, i.e., NU + 1 is the number of +C nonzero blocks in the first block row of T. +C If TRIU = 'N', 0 <= NU < N and +C (M + NU)*L >= MIN( M*K, N*L ); +C if TRIU = 'T', MAX(1-ML,0) <= NU < N and +C (M + NU)*L >= MIN( M*K, N*L ). +C +C P (input) INTEGER +C The number of previously computed block columns of R. +C P*L < MIN( M*K,N*L ) + L and P >= 0. +C +C S (input) INTEGER +C The number of block columns of R to compute. +C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) +C On entry, if P = 0, the leading (ML+1)*K-by-L part of this +C array must contain the nonzero blocks in the first block +C column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. +C LDTC >= MAX(1,(ML+1)*K), if P = 0. +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,NU*L) +C On entry, if P = 0, the leading K-by-NU*L part of this +C array must contain the 2nd to the (NU+1)-st blocks of +C the first block row of T. +C +C LDTR INTEGER +C The leading dimension of the array TR. +C LDTR >= MAX(1,K), if P = 0. +C +C RB (output) DOUBLE PRECISION array, dimension +C (LDRB,MIN( S*L,MIN( M*K,N*L )-P*L )) +C On exit, if INFO = 0 and TRIU = 'N', the leading +C MIN( ML+NU+1,N )*L-by-MIN( S*L,MIN( M*K,N*L )-P*L ) part +C of this array contains the (P+1)-th to (P+S)-th block +C column of the lower R factor (1) in band storage format. +C On exit, if INFO = 0 and TRIU = 'T', the leading +C MIN( (ML+NU)*L+1,N*L )-by-MIN( S*L,MIN( M*K,N*L )-P*L ) +C part of this array contains the (P+1)-th to (P+S)-th block +C column of the lower R factor (1) in band storage format. +C For further details regarding the band storage scheme see +C the documentation of the LAPACK routine DPBTF2. +C +C LDRB INTEGER +C The leading dimension of the array RB. +C LDRB >= MAX( MIN( ML+NU+1,N )*L,1 ), if TRIU = 'N'; +C LDRB >= MAX( MIN( (ML+NU)*L+1,N*L ),1 ), if TRIU = 'T'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C The first 1 + 2*MIN( ML+NU+1,N )*L*(K+L) elements of DWORK +C should be preserved during successive calls of the routine. +C +C LDWORK INTEGER +C The length of the array DWORK. +C Let x = MIN( ML+NU+1,N ), then +C LDWORK >= 1 + MAX( x*L*L + (2*NU+1)*L*K, +C 2*x*L*(K+L) + (6+x)*L ), if P = 0; +C LDWORK >= 1 + 2*x*L*(K+L) + (6+x)*L, if P > 0. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the full rank condition for the first MIN(M*K, N*L) +C columns of T is (numerically) violated. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method yields a factor R which has comparable +C accuracy with the Cholesky factor of T^T * T. +C The algorithm requires +C 2 2 +C O( L *K*N*( ML + NU ) + N*( ML + NU )*L *( L + K ) ) +C +C floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRIU + INTEGER INFO, K, L, LDRB, LDTC, LDTR, LDWORK, M, ML, N, + $ NU, P, S +C .. Array Arguments .. + DOUBLE PRECISION DWORK(LDWORK), RB(LDRB,*), TC(LDTC,*), + $ TR(LDTR,*) +C .. Local Scalars .. + CHARACTER STRUCT + INTEGER COL2, HEAD, I, IERR, J, KK, LEN, LEN2, LENC, + $ LENL, LENR, NB, NBMIN, PDC, PDR, PDW, PFR, PNR, + $ POSR, PRE, PT, RNK, SIZR, STPS, WRKMIN, WRKOPT, + $ X + LOGICAL LTRI +C .. Local Arrays .. + INTEGER IPVT(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, + $ MA02AD, MB02CU, MB02CV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, MOD +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LTRI = LSAME( TRIU, 'T' ) + X = MIN( ML + NU + 1, N ) + LENR = X*L + IF ( LTRI ) THEN + SIZR = MIN( ( ML + NU )*L + 1, N*L ) + ELSE + SIZR = LENR + END IF + IF ( P.EQ.0 ) THEN + WRKMIN = 1 + MAX( LENR*L + ( 2*NU + 1 )*L*K, + $ 2*LENR*( K + L ) + ( 6 + X )*L ) + ELSE + WRKMIN = 1 + 2*LENR*( K + L ) + ( 6 + X )*L + END IF + POSR = 1 +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRI .OR. LSAME( TRIU, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( L.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.1 ) THEN + INFO = -4 + ELSE IF ( ML.GE.M .OR. ( ML + 1 )*K.LT.L .OR. ( M*K.LE.N*L .AND. + $ ( ( ML.LT.M - INT( ( M*K - 1 )/L ) - 1 ) .OR. + $ ( ML.LT.M - INT( M*K/L ).AND.MOD( M*K, L ).LT.K ) ) ) + $ .OR. ( M*K.GE.N*L .AND. ML*K.LT.N*( L - K ) ) ) THEN + INFO = -5 + ELSE IF ( N.LT.1 ) THEN + INFO = -6 + ELSE IF ( NU.GE.N .OR. NU.LT.0 .OR. ( LTRI .AND. NU.LT.1-ML ) .OR. + $ (M + NU)*L.LT.MIN( M*K, N*L ) ) THEN + INFO = -7 + ELSE IF ( P.LT.0 .OR. ( P*L - L ).GE.MIN( M*K, N*L ) ) THEN + INFO = -8 + ELSE IF ( S.LT.0 .OR. ( P + S - 1 )*L.GE.MIN( M*K, N*L ) ) THEN + INFO = -9 + ELSE IF ( P.EQ.0 .AND. LDTC.LT.MAX( 1, ( ML + 1 )*K ) ) THEN + INFO = -11 + ELSE IF ( P.EQ.0 .AND. LDTR.LT.MAX( 1, K ) ) THEN + INFO = -13 + ELSE IF ( LDRB.LT.MAX( SIZR, 1 ) ) THEN + INFO = 15 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02HD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( L*K*S.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + WRKOPT = 1 +C +C Compute the generator if P = 0. +C + IF ( P.EQ.0 ) THEN +C +C 1st column of the generator. +C + LENC = ( ML + 1 )*K + LENL = MAX( ML + 1 + MIN( NU, N - M ), 0 ) + PDC = LENR*L + 1 + PDW = PDC + LENC*L +C +C QR decomposition of the nonzero blocks in TC. +C + CALL DLACPY( 'All', LENC, L, TC, LDTC, DWORK(PDC+1), LENC ) + CALL DGEQRF( LENC, L, DWORK(PDC+1), LENC, DWORK(PDW+1), + $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) +C +C The R factor is the transposed of the first block in the +C generator. +C + CALL MA02AD( 'Upper part', L, L, DWORK(PDC+1), LENC, DWORK(2), + $ LENR ) +C +C Get the first block column of the Q factor. +C + CALL DORGQR( LENC, L, L, DWORK(PDC+1), LENC, DWORK(PDW+1), + $ DWORK(PDW+L+1), LDWORK-PDW-L, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L+1) ) + PDW + L ) +C +C Construct a flipped copy of TC for faster multiplication. +C + PT = LENC - 2*K + 1 +C + DO 10 I = PDW + 1, PDW + ML*K*L, K*L + CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) + PT = PT - K + 10 CONTINUE +C +C Multiply T^T with the first block column of Q. +C + PDW = I + PDR = L + 2 + LEN = NU*L + CALL DLASET( 'All', LENR-L, L, ZERO, ZERO, DWORK(PDR), LENR ) +C + DO 20 I = 1, ML + 1 + CALL DGEMM( 'Transpose', 'NonTranspose', MIN( I-1, N-1 )*L, + $ L, K, ONE, DWORK(PDW), K, DWORK(PDC+1), LENC, + $ ONE, DWORK(PDR), LENR ) + IF ( LEN.GT.0 ) THEN + CALL DGEMM( 'Transpose', 'NonTranspose', LEN, L, K, ONE, + $ TR, LDTR, DWORK(PDC+1), LENC, ONE, + $ DWORK(PDR+(I-1)*L), LENR ) + END IF + PDW = PDW - K*L + PDC = PDC + K + IF ( I.GE.N-NU ) LEN = LEN - L + 20 CONTINUE +C +C Copy the first block column to R. +C + IF ( LTRI ) THEN +C + DO 30 I = 1, L + CALL DCOPY( MIN( SIZR, N*L - I + 1 ), + $ DWORK(( I - 1 )*LENR + I + 1), 1, RB(1,POSR), + $ 1 ) + POSR = POSR + 1 + 30 CONTINUE +C + ELSE +C + DO 40 I = 1, L + CALL DCOPY( LENR-I+1, DWORK(( I - 1 )*LENR + I + 1), 1, + $ RB(1,POSR), 1 ) + IF ( LENR.LT.N*L .AND. I.GT.1 ) THEN + CALL DLASET( 'All', I-1, 1, ZERO, ZERO, + $ RB(LENR-I+2,POSR), LDRB ) + END IF + POSR = POSR + 1 + 40 CONTINUE +C + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + DWORK(1) = DBLE( WRKOPT ) + RETURN + END IF +C +C 2nd column of the generator. +C + PDR = LENR*L + 1 + CALL MA02AD( 'All', K, NU*L, TR, LDTR, DWORK(PDR+1), LENR ) + CALL DLASET( 'All', LENR-NU*L, K, ZERO, ZERO, + $ DWORK(PDR+NU*L+1), LENR ) +C +C 3rd column of the generator. +C + PNR = PDR + LENR*K + CALL DLACPY( 'All', LENR-L, L, DWORK(L+2), LENR, DWORK(PNR+1), + $ LENR ) + CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PNR+LENR-L+1), + $ LENR ) +C +C 4th column of the generator. +C + PFR = PNR + LENR*L +C + PDW = PFR + MOD( ( M - ML - 1 )*L, LENR ) + PT = ML*K + 1 + DO 50 I = 1, MIN( ML + 1, LENL ) + CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW+1), + $ LENR ) + PT = PT - K + PDW = PFR + MOD( PDW + L - PFR, LENR ) + 50 CONTINUE + PT = 1 + DO 60 I = ML + 2, LENL + CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW+1), + $ LENR ) + PT = PT + L + PDW = PFR + MOD( PDW + L - PFR, LENR ) + 60 CONTINUE + PRE = 1 + STPS = S - 1 + ELSE + PDR = LENR*L + 1 + PNR = PDR + LENR*K + PFR = PNR + LENR*L + PRE = P + STPS = S + END IF +C + PDW = PFR + LENR*K + HEAD = MOD( ( PRE - 1 )*L, LENR ) +C +C Determine block size for the involved block Householder +C transformations. +C + NB = MIN( ILAENV( 1, 'DGELQF', ' ', LENR, L, -1, -1 ), L ) + KK = PDW + 6*L + WRKOPT = MAX( WRKOPT, KK + LENR*NB ) + KK = LDWORK - KK + IF ( KK.LT.LENR*NB ) NB = KK / LENR + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LENR, L, -1, -1 ) ) + IF ( NB.LT.NBMIN ) NB = 0 +C +C Generator reduction process. +C + DO 90 I = PRE, PRE + STPS - 1 +C +C The 4th generator column is not used in the first (M-ML) steps. +C + IF ( I.LT.M-ML ) THEN + COL2 = L + ELSE + COL2 = K + L + END IF +C + KK = MIN( L, M*K - I*L ) + CALL MB02CU( 'Column', KK, KK+K, COL2, NB, DWORK(2), LENR, + $ DWORK(PDR+HEAD+1), LENR, DWORK(PNR+HEAD+1), LENR, + $ RNK, IPVT, DWORK(PDW+1), ZERO, DWORK(PDW+6*L+1), + $ LDWORK-PDW-6*L, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The rank condition is (numerically) not +C satisfied. +C + INFO = 1 + RETURN + END IF +C + LEN = MAX( MIN( ( N - I )*L - KK, LENR - HEAD - KK ), 0 ) + LEN2 = MAX( MIN( ( N - I )*L - LEN - KK, HEAD ), 0 ) + IF ( LEN.EQ.( LENR - KK ) ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF + CALL MB02CV( 'Column', STRUCT, KK, LEN, KK+K, COL2, NB, -1, + $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, + $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+2), LENR, + $ DWORK(PDR+HEAD+KK+1), LENR, DWORK(PNR+HEAD+KK+1), + $ LENR, DWORK(PDW+1), DWORK(PDW+6*L+1), + $ LDWORK-PDW-6*L, IERR ) +C + IF ( ( N - I )*L.GE.LENR ) THEN + STRUCT = TRIU + ELSE + STRUCT = 'N' + END IF +C + CALL MB02CV( 'Column', STRUCT, KK, LEN2, KK+K, COL2, NB, -1, + $ DWORK(2), LENR, DWORK(PDR+HEAD+1), LENR, + $ DWORK(PNR+HEAD+1), LENR, DWORK(KK+LEN+2), LENR, + $ DWORK(PDR+1), LENR, DWORK(PNR+1), LENR, + $ DWORK(PDW+1), DWORK(PDW+6*L+1), + $ LDWORK-PDW-6*L, IERR ) +C + CALL DLASET( 'All', L, K+COL2, ZERO, ZERO, DWORK(PDR+HEAD+1), + $ LENR ) +C +C Copy current block column to R. +C + IF ( LTRI ) THEN +C + DO 70 J = 1, KK + CALL DCOPY( MIN( SIZR, (N-I)*L-J+1 ), + $ DWORK(( J - 1 )*LENR + J + 1), 1, + $ RB(1,POSR), 1 ) + POSR = POSR + 1 + 70 CONTINUE +C + ELSE +C + DO 80 J = 1, KK + CALL DCOPY( MIN( SIZR-J+1, (N-I)*L-J+1 ), + $ DWORK(( J - 1 )*LENR + J + 1), 1, + $ RB(1,POSR), 1 ) + IF ( LENR.LT.( N - I )*L .AND. J.GT.1 ) THEN + CALL DLASET( 'All', J-1, 1, ZERO, ZERO, + $ RB(MIN( SIZR-J+1, (N-I)*L-J+1 )+1,POSR), + $ LDRB ) + END IF + POSR = POSR + 1 + 80 CONTINUE +C + END IF +C + HEAD = MOD( HEAD + L, LENR ) + 90 CONTINUE +C + DWORK(1) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of MB02HD *** + END diff --git a/mex/sources/libslicot/MB02ID.f b/mex/sources/libslicot/MB02ID.f new file mode 100644 index 000000000..a0e5e659b --- /dev/null +++ b/mex/sources/libslicot/MB02ID.f @@ -0,0 +1,508 @@ + SUBROUTINE MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B, + $ LDB, C, LDC, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the overdetermined or underdetermined real linear systems +C involving an M*K-by-N*L block Toeplitz matrix T that is specified +C by its first block column and row. It is assumed that T has full +C rank. +C The following options are provided: +C +C 1. If JOB = 'O' or JOB = 'A' : find the least squares solution of +C an overdetermined system, i.e., solve the least squares problem +C +C minimize || B - T*X ||. (1) +C +C 2. If JOB = 'U' or JOB = 'A' : find the minimum norm solution of +C the undetermined system +C T +C T * X = C. (2) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the problem to be solved as follows +C = 'O': solve the overdetermined system (1); +C = 'U': solve the underdetermined system (2); +C = 'A': solve (1) and (2). +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in the blocks of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in the blocks of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in the first block column of T. +C M >= 0. +C +C N (input) INTEGER +C The number of blocks in the first block row of T. +C 0 <= N <= M*K / L. +C +C RB (input) INTEGER +C If JOB = 'O' or 'A', the number of columns in B. RB >= 0. +C +C RC (input) INTEGER +C If JOB = 'U' or 'A', the number of columns in C. RC >= 0. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) +C On entry, the leading M*K-by-L part of this array must +C contain the first block column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. LDTC >= MAX(1,M*K) +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) +C On entry, the leading K-by-(N-1)*L part of this array must +C contain the 2nd to the N-th blocks of the first block row +C of T. +C +C LDTR INTEGER +C The leading dimension of the array TR. LDTR >= MAX(1,K). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,RB) +C On entry, if JOB = 'O' or JOB = 'A', the leading M*K-by-RB +C part of this array must contain the right hand side +C matrix B of the overdetermined system (1). +C On exit, if JOB = 'O' or JOB = 'A', the leading N*L-by-RB +C part of this array contains the solution of the +C overdetermined system (1). +C This array is not referenced if JOB = 'U'. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,M*K), if JOB = 'O' or JOB = 'A'; +C LDB >= 1, if JOB = 'U'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,RC) +C On entry, if JOB = 'U' or JOB = 'A', the leading N*L-by-RC +C part of this array must contain the right hand side +C matrix C of the underdetermined system (2). +C On exit, if JOB = 'U' or JOB = 'A', the leading M*K-by-RC +C part of this array contains the solution of the +C underdetermined system (2). +C This array is not referenced if JOB = 'O'. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDB >= 1, if JOB = 'O'; +C LDB >= MAX(1,M*K), if JOB = 'U' or JOB = 'A'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C Let x = MAX( 2*N*L*(L+K) + (6+N)*L,(N*L+M*K+1)*L + M*K ) +C and y = N*M*K*L + N*L, then +C if MIN( M,N ) = 1 and JOB = 'O', +C LDWORK >= MAX( y + MAX( M*K,RB ),1 ); +C if MIN( M,N ) = 1 and JOB = 'U', +C LDWORK >= MAX( y + MAX( M*K,RC ),1 ); +C if MIN( M,N ) = 1 and JOB = 'A', +C LDWORK >= MAX( y +MAX( M*K,MAX( RB,RC ),1 ); +C if MIN( M,N ) > 1 and JOB = 'O', +C LDWORK >= MAX( x,N*L*RB + 1 ); +C if MIN( M,N ) > 1 and JOB = 'U', +C LDWORK >= MAX( x,N*L*RC + 1 ); +C if MIN( M,N ) > 1 and JOB = 'A', +C LDWORK >= MAX( x,N*L*MAX( RB,RC ) + 1 ). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction algorithm failed. The Toeplitz matrix +C associated with T is (numerically) not of full rank. +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O( L*L*K*(N+M)*log(N+M) + N*N*L*L*(L+K) ) +C and additionally +C +C if JOB = 'O' or JOB = 'A', +C O( (K*L+RB*L+K*RB)*(N+M)*log(N+M) + N*N*L*L*RB ); +C if JOB = 'U' or JOB = 'A', +C O( (K*L+RC*L+K*RC)*(N+M)*log(N+M) + N*N*L*L*RC ); +C +C floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, + $ RB, RC +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(LDWORK), TC(LDTC,*), + $ TR(LDTR,*) +C .. Local Scalars .. + INTEGER I, IERR, KK, LEN, NB, NBMIN, PDI, PDW, PNI, PNR, + $ PPI, PPR, PT, RNK, WRKMIN, WRKOPT, X, Y + LOGICAL COMPO, COMPU +C .. Local Arrays .. + INTEGER IPVT(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DGELS, DGEMM, DGEQRF, DLACPY, DLASET, DORGQR, + $ DTRMM, DTRSM, DTRTRI, MA02AD, MB02CU, MB02CV, + $ MB02KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COMPO = LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' ) + COMPU = LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' ) + X = MAX( 2*N*L*( L + K ) + ( 6 + N )*L, + $ ( N*L + M*K + 1 )*L + M*K ) + Y = N*M*K*L + N*L + IF ( MIN( M, N ).EQ.1 ) THEN + WRKMIN = MAX( M*K, 1 ) + IF ( COMPO ) WRKMIN = MAX( WRKMIN, RB ) + IF ( COMPU ) WRKMIN = MAX( WRKMIN, RC ) + WRKMIN = MAX( Y + WRKMIN, 1 ) + ELSE + WRKMIN = X + IF ( COMPO ) WRKMIN = MAX( WRKMIN, N*L*RB + 1 ) + IF ( COMPU ) WRKMIN = MAX( WRKMIN, N*L*RC + 1 ) + END IF + WRKOPT = 1 +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPO .OR. COMPU ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( L.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 .OR. ( N*L ).GT.( M*K ) ) THEN + INFO = -5 + ELSE IF ( COMPO .AND. RB.LT.0 ) THEN + INFO = -6 + ELSE IF ( COMPU .AND. RC.LT.0 ) THEN + INFO = -7 + ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN + INFO = -9 + ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN + INFO = -11 + ELSE IF ( LDB.LT.1 .OR. ( COMPO .AND. LDB.LT.M*K ) ) THEN + INFO = -13 + ELSE IF ( LDC.LT.1 .OR. ( COMPU .AND. LDC.LT.M*K ) ) THEN + INFO = -15 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02ID', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( COMPO .AND. MIN( N*L, RB ).EQ.0 ) THEN + COMPO = .FALSE. + END IF + IF( COMPU .AND. MIN( N*L, RC ).EQ.0 ) THEN + CALL DLASET( 'Full', M*K, RC, ZERO, ZERO, C, LDC ) + COMPU = .FALSE. + END IF + IF ( .NOT.( COMPO .OR. COMPU ) ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Check cases M = 1 or N = 1. +C + IF ( MIN( M, N ).EQ.1 ) THEN + PDW = K*L*M*N + IF ( COMPO ) THEN + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) + CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), + $ M*K ) + CALL DGELS( 'NonTranspose', M*K, N*L, RB, DWORK, M*K, B, + $ LDB, DWORK(PDW+1), LDWORK-PDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) + END IF + IF ( COMPU ) THEN + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) + CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1), + $ M*K ) + CALL DGELS( 'Transpose', M*K, N*L, RC, DWORK, M*K, C, LDC, + $ DWORK(PDW+1), LDWORK-PDW, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW ) + END IF + DWORK(1) = DBLE( WRKOPT ) + RETURN + END IF +C +C Step 1: Compute the generator. +C + IF ( COMPO ) THEN + CALL MB02KD( 'Column', 'Transpose', K, L, M, N, RB, ONE, ZERO, + $ TC, LDTC, TR, LDTR, B, LDB, DWORK, N*L, + $ DWORK(N*L*RB+1), LDWORK-N*L*RB, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(N*L*RB+1) ) + N*L*RB ) + CALL DLACPY( 'All', N*L, RB, DWORK, N*L, B, LDB ) + END IF +C + PDW = N*L*L + 1 + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK(PDW), M*K ) + CALL DGEQRF( M*K, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), + $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + + $ PDW + (M*K+1)*L - 1 ) +C + DO 10 I = PDW, PDW + M*K*L - 1, M*K + 1 + IF ( DWORK(I).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF + 10 CONTINUE +C + CALL MA02AD( 'Upper', L, L, DWORK(PDW), M*K, DWORK, N*L ) + CALL DORGQR( M*K, L, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L), + $ DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) + + $ PDW + (M*K+1)*L - 1 ) + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, ZERO, + $ TC, LDTC, TR, LDTR, DWORK(PDW), M*K, DWORK(L+1), + C N*L, DWORK(PDW+M*K*L), LDWORK-PDW-M*K*L+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K*L) ) + PDW + M*K*L - 1 ) + PPR = N*L*L + 1 + PNR = N*L*( L + K ) + 1 + CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(PPR+L), N*L ) + CALL DLACPY( 'All', (N-1)*L, L, DWORK(L+1), N*L, DWORK(PNR+L), + $ N*L ) + PT = ( M - 1 )*K + 1 + PDW = PNR + N*L*L + L +C + DO 30 I = 1, MIN( M, N-1 ) + CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), N*L ) + PT = PT - K + PDW = PDW + L + 30 CONTINUE +C + PT = 1 +C + DO 40 I = M + 1, N - 1 + CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), N*L ) + PT = PT + L + PDW = PDW + L + 40 CONTINUE +C + IF ( COMPO ) THEN +C +C Apply the first reduction step to T'*B. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', + $ L, RB, ONE, DWORK, N*L, B, LDB ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RB, L, ONE, + $ DWORK(L+1), N*L, B, LDB, -ONE, B(L+1,1), LDB ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, + $ RB, ONE, DWORK, N*L, B, LDB ) + END IF +C + IF ( COMPU ) THEN +C +C Apply the first reduction step to C. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', + $ L, RC, ONE, DWORK, N*L, C, LDC ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RC, L, ONE, + $ DWORK(L+1), N*L, C, LDC, -ONE, C(L+1,1), LDC ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L, + $ RC, ONE, DWORK, N*L, C, LDC ) + END IF +C + PDI = ( N - 1 )*L + 1 + CALL DLACPY( 'Lower', L, L, DWORK, N*L, DWORK(PDI), N*L ) + CALL DTRTRI( 'Lower', 'NonUnit', L, DWORK(PDI), N*L, IERR ) + CALL MA02AD( 'Lower', L-1, L, DWORK(PDI+1), N*L, + $ DWORK((2*N-1)*L+1), N*L ) + CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PDI+1), N*L ) + CALL DLACPY( 'Upper', L, L, DWORK(PDI), N*L, DWORK(PNR), N*L ) + CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PNR+1), N*L ) + CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PPR), N*L ) + CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PNR+N*L*L), N*L ) +C + PPI = PPR + PPR = PPR + L + PNI = PNR + PNR = PNR + L + PDW = 2*N*L*( L + K ) + 1 + LEN = ( N - 1 )*L +C +C Determine block size for the involved block Householder +C transformations. +C + NB = MIN( ILAENV( 1, 'DGELQF', ' ', N*L, L, -1, -1 ), L ) + KK = PDW + 6*L - 1 + WRKOPT = MAX( WRKOPT, KK + N*L*NB ) + KK = LDWORK - KK + IF ( KK.LT.N*L*NB ) NB = KK / ( N*L ) + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', N*L, L, -1, -1 ) ) + IF ( NB.LT.NBMIN ) NB = 0 +C + DO 50 I = L + 1, N*L, L + CALL MB02CU( 'Column', L, L+K, L+K, NB, DWORK, N*L, DWORK(PPR), + $ N*L, DWORK(PNR), N*L, RNK, IPVT, DWORK(PDW), ZERO, + $ DWORK(PDW+6*L), LDWORK-PDW-6*L+1, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The rank condition is (numerically) not +C satisfied. +C + INFO = 1 + RETURN + END IF + CALL MB02CV( 'Column', 'NoStructure', L, LEN-L, L+K, L+K, NB, + $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, + $ DWORK(L+1), N*L, DWORK(PPR+L), N*L, DWORK(PNR+L), + $ N*L, DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, + $ IERR ) + PDI = PDI - L + IF ( COMPO ) THEN +C +C Block Gaussian elimination to B. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', + $ L, RB, -ONE, DWORK, N*L, B(I,1), LDB ) + IF ( LEN.GT.L ) THEN + CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RB, L, + $ ONE, DWORK(L+1), N*L, B(I,1), LDB, ONE, + $ B(I+L,1), LDB ) + END IF + END IF + IF ( COMPU ) THEN +C +C Block Gaussian elimination to C. +C + CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit', + $ L, RC, -ONE, DWORK, N*L, C(I,1), LDC ) + IF ( LEN.GT.L ) THEN + CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RC, L, + $ ONE, DWORK(L+1), N*L, C(I,1), LDC, ONE, + $ C(I+L,1), LDC ) + END IF + END IF + CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PDI), N*L ) + CALL MB02CV( 'Column', 'Triangular', L, I+L-1, L+K, L+K, NB, + $ -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L, + $ DWORK(PDI), N*L, DWORK(PPI), N*L, DWORK(PNI), N*L, + $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, + $ IERR ) + IF ( COMPO ) THEN +C +C Apply block Gaussian elimination to B. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', I-1, RB, L, ONE, + $ DWORK(PDI), N*L, B(I,1), LDB, ONE, B, LDB ) + CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, + $ RB, ONE, DWORK((N-1)*L+1), N*L, B(I,1), LDB ) + END IF + IF ( COMPU ) THEN +C +C Apply block Gaussian elimination to C. +C + CALL DGEMM( 'NonTranspose', 'NonTranspose', I-1, RC, L, ONE, + $ DWORK(PDI), N*L, C(I,1), LDC, ONE, C, LDC ) + CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L, + $ RC, ONE, DWORK((N-1)*L+1), N*L, C(I,1), LDC ) + END IF + LEN = LEN - L + PNR = PNR + L + PPR = PPR + L + 50 CONTINUE +C + IF ( COMPU ) THEN + CALL MB02KD( 'Column', 'NonTranspose', K, L, M, N, RC, ONE, + $ ZERO, TC, LDTC, TR, LDTR, C, LDC, DWORK, M*K, + $ DWORK(M*K*RC+1), LDWORK-M*K*RC, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M*K*RC+1) ) + M*K*RC ) + CALL DLACPY( 'All', M*K, RC, DWORK, M*K, C, LDC ) + END IF + DWORK(1) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of MB02ID *** + END diff --git a/mex/sources/libslicot/MB02JD.f b/mex/sources/libslicot/MB02JD.f new file mode 100644 index 000000000..95c49b43a --- /dev/null +++ b/mex/sources/libslicot/MB02JD.f @@ -0,0 +1,486 @@ + SUBROUTINE MB02JD( JOB, K, L, M, N, P, S, TC, LDTC, TR, LDTR, Q, + $ LDQ, R, LDR, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a lower triangular matrix R and a matrix Q with +C Q^T Q = I such that +C T +C T = Q R , +C +C where T is a K*M-by-L*N block Toeplitz matrix with blocks of size +C (K,L). The first column of T will be denoted by TC and the first +C row by TR. It is assumed that the first MIN(M*K, N*L) columns of T +C have full rank. +C +C By subsequent calls of this routine the factors Q and R can be +C computed block column by block column. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the output of the routine as follows: +C = 'Q': computes Q and R; +C = 'R': only computes R. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in one block of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in one block of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in one block column of T. M >= 0. +C +C N (input) INTEGER +C The number of blocks in one block row of T. N >= 0. +C +C P (input) INTEGER +C The number of previously computed block columns of R. +C P*L < MIN( M*K,N*L ) + L and P >= 0. +C +C S (input) INTEGER +C The number of block columns of R to compute. +C (P+S)*L < MIN( M*K,N*L ) + L and S >= 0. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) +C On entry, if P = 0, the leading M*K-by-L part of this +C array must contain the first block column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. +C LDTC >= MAX(1,M*K). +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) +C On entry, if P = 0, the leading K-by-(N-1)*L part of this +C array must contain the first block row of T without the +C leading K-by-L block. +C +C LDTR INTEGER +C The leading dimension of the array TR. +C LDTR >= MAX(1,K). +C +C Q (input/output) DOUBLE PRECISION array, dimension +C (LDQ,MIN( S*L, MIN( M*K,N*L )-P*L )) +C On entry, if JOB = 'Q' and P > 0, the leading M*K-by-L +C part of this array must contain the last block column of Q +C from a previous call of this routine. +C On exit, if JOB = 'Q' and INFO = 0, the leading +C M*K-by-MIN( S*L, MIN( M*K,N*L )-P*L ) part of this array +C contains the P-th to (P+S)-th block columns of the factor +C Q. +C +C LDQ INTEGER +C The leading dimension of the array Q. +C LDQ >= MAX(1,M*K), if JOB = 'Q'; +C LDQ >= 1, if JOB = 'R'. +C +C R (input/output) DOUBLE PRECISION array, dimension +C (LDR,MIN( S*L, MIN( M*K,N*L )-P*L )) +C On entry, if P > 0, the leading (N-P+1)*L-by-L +C part of this array must contain the nozero part of the +C last block column of R from a previous call of this +C routine. +C One exit, if INFO = 0, the leading +C MIN( N, N-P+1 )*L-by-MIN( S*L, MIN( M*K,N*L )-P*L ) +C part of this array contains the nonzero parts of the P-th +C to (P+S)-th block columns of the lower triangular +C factor R. +C Note that elements in the strictly upper triangular part +C will not be referenced. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX( 1, MIN( N, N-P+1 )*L ) +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C On exit, if INFO = -17, DWORK(1) returns the minimum +C value of LDWORK. +C If JOB = 'Q', the first 1 + ( (N-1)*L + M*K )*( 2*K + L ) +C elements of DWORK should be preserved during successive +C calls of the routine. +C If JOB = 'R', the first 1 + (N-1)*L*( 2*K + L ) elements +C of DWORK should be preserved during successive calls of +C the routine. +C +C LDWORK INTEGER +C The length of the array DWORK. +C JOB = 'Q': +C LDWORK >= 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L +C + MAX( M*K,( N - MAX( 1,P )*L ) ); +C JOB = 'R': +C If P = 0, +C LDWORK >= MAX( 1 + ( N - 1 )*L*( L + 2*K ) + 6*L +C + (N-1)*L, M*K*( L + 1 ) + L ); +C If P > 0, +C LDWORK >= 1 + (N-1)*L*( L + 2*K ) + 6*L + (N-P)*L. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the full rank condition for the first MIN(M*K, N*L) +C columns of T is (numerically) violated. +C +C METHOD +C +C Block Householder transformations and modified hyperbolic +C rotations are used in the Schur algorithm [1], [2]. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The implemented method yields a factor R which has comparable +C accuracy with the Cholesky factor of T^T * T. Q is implicitly +C computed from the formula Q = T * inv(R^T R) * R, i.e., for ill +C conditioned problems this factor is of very limited value. +C 2 +C The algorithm requires 0(K*L *M*N) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, + $ M, N, P, S +C .. Array Arguments .. + DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), + $ TR(LDTR,*) +C .. Local Scalars .. + INTEGER COLR, I, IERR, KK, LEN, NB, NBMIN, PDQ, PDW, + $ PNQ, PNR, PRE, PT, RNK, SHFR, STPS, WRKMIN, + $ WRKOPT + LOGICAL COMPQ +C .. Local Arrays .. + INTEGER IPVT(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DGEQRF, DLACPY, DLASET, DORGQR, MA02AD, MB02CU, + $ MB02CV, MB02KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + COMPQ = LSAME( JOB, 'Q' ) + IF ( COMPQ ) THEN + WRKMIN = 1 + ( M*K + ( N - 1 )*L )*( L + 2*K ) + 6*L + $ + MAX( M*K, ( N - MAX( 1, P ) )*L ) + ELSE + WRKMIN = 1 + ( N - 1 )*L*( L + 2*K ) + 6*L + $ + ( N - MAX( P, 1 ) )*L + IF ( P.EQ.0 ) THEN + WRKMIN = MAX( WRKMIN, M*K*( L + 1 ) + L ) + END IF + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( L.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( P*L.GE.MIN( M*K, N*L ) + L .OR. P.LT.0 ) THEN + INFO = -6 + ELSE IF ( ( P + S )*L.GE.MIN( M*K, N*L ) + L .OR. S.LT.0 ) THEN + INFO = -7 + ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN + INFO = -9 + ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN + INFO = -11 + ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.M*K ) ) THEN + INFO = -13 + ELSE IF ( LDR.LT.MAX( 1, MIN( N, N - P + 1 )*L ) ) THEN + INFO = -15 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'MB02JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, N, K*L, S ) .EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Catch M*K <= L. +C + WRKOPT = 1 + IF ( M*K.LE.L ) THEN + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) + PDW = M*K*L + 1 + CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), + $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) + CALL MA02AD( 'Upper part', M*K, L, DWORK, M*K, R, LDR ) + CALL DORGQR( M*K, M*K, M*K, DWORK, M*K, DWORK(PDW), + $ DWORK(PDW+M*K), LDWORK-PDW-M*K+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K) ) + PDW + M*K - 1 ) + IF ( COMPQ ) THEN + CALL DLACPY( 'All', M*K, M*K, DWORK, M*K, Q, LDQ ) + END IF + PDW = M*K*M*K + 1 + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, M*K, ONE, + $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, R(L+1,1), + $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + DWORK(1) = DBLE( WRKOPT ) + RETURN + END IF +C +C Compute the generator if P = 0. +C + IF ( P.EQ.0 ) THEN +C +C 1st column of the generator. +C + IF ( COMPQ ) THEN + CALL DLACPY( 'All', M*K, L, TC, LDTC, Q, LDQ ) + CALL DGEQRF( M*K, L, Q, LDQ, DWORK, DWORK(L+1), + $ LDWORK-L, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) + CALL MA02AD( 'Upper part', L, L, Q, LDQ, R, LDR ) + CALL DORGQR( M*K, L, L, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, + $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), + $ LDR, DWORK, LDWORK, IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + ELSE + PDW = M*K*L + 1 + CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K ) + CALL DGEQRF( M*K, L, DWORK, M*K, DWORK(PDW), DWORK(PDW+L), + $ LDWORK-PDW-L+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) + CALL MA02AD( 'Upper part', L, L, DWORK, M*K, R, LDR ) + CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK(PDW), + $ DWORK(PDW+L), LDWORK-PDW-L+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+L) ) + PDW + L - 1 ) + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, + $ ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, + $ R(L+1,1), LDR, DWORK(PDW), LDWORK-PDW+1, + $ IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + DWORK(1) = DBLE( WRKOPT ) + RETURN + END IF +C +C 2nd column of the generator. +C + PNR = ( N - 1 )*L*K + 2 + CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(2), (N-1)*L ) +C +C 3rd and 4th column of the generator. +C + CALL DLACPY( 'All', (N-1)*L, L, R(L+1,1), LDR, DWORK(PNR), + $ (N-1)*L ) + PT = ( M - 1 )*K + 1 + PDW = PNR + ( N - 1 )*L*L +C + DO 10 I = 1, MIN( M, N-1 ) + CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), + $ (N-1)*L ) + PT = PT - K + PDW = PDW + L + 10 CONTINUE +C + PT = 1 +C + DO 20 I = M + 1, N - 1 + CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), + $ (N-1)*L ) + PT = PT + L + PDW = PDW + L + 20 CONTINUE +C + IF ( COMPQ ) THEN + PDQ = ( 2*K + L )*( N - 1 )*L + 2 + PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 + PNQ = PDQ + M*K*K + CALL DLASET( 'All', K, K, ZERO, ONE, DWORK(PDQ), M*K ) + CALL DLASET( 'All', (M-1)*K, K, ZERO, ZERO, DWORK(PDQ+K), + $ M*K ) + CALL DLACPY( 'All', M*K, L, Q, LDQ, DWORK(PNQ), M*K ) + CALL DLASET( 'All', M*K, K, ZERO, ZERO, DWORK(PNQ+M*L*K), + $ M*K ) + ELSE + PDW = ( 2*K + L )*( N - 1 )*L + 2 + END IF + PRE = 1 + STPS = S - 1 + ELSE +C +C Set workspace pointers. +C + PNR = ( N - 1 )*L*K + 2 + IF ( COMPQ ) THEN + PDQ = ( 2*K + L )*( N - 1 )*L + 2 + PDW = ( 2*K + L )*( ( N - 1 )*L + M*K ) + 2 + PNQ = PDQ + M*K*K + ELSE + PDW = ( 2*K + L )*( N - 1 )*L + 2 + END IF + PRE = P + STPS = S + END IF +C +C Determine suitable size for the block Housholder reflectors. +C + IF ( COMPQ ) THEN + LEN = MAX( L + M*K, ( N - PRE + 1 )*L ) + ELSE + LEN = ( N - PRE + 1 )*L + END IF + NB = MIN( ILAENV( 1, 'DGELQF', ' ', LEN, L, -1, -1 ), L ) + KK = PDW + 6*L - 1 + WRKOPT = MAX( WRKOPT, KK + LEN*NB ) + KK = LDWORK - KK + IF ( KK.LT.LEN*NB ) NB = KK / LEN + NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', LEN, L, -1, -1 ) ) + IF ( NB.LT.NBMIN ) NB = 0 + COLR = L + 1 +C +C Generator reduction process. +C + LEN = ( N - PRE )*L + SHFR = ( PRE - 1 )*L + DO 30 I = PRE, PRE + STPS - 1 +C +C IF M*K < N*L the last block might have less than L columns. +C + KK = MIN( L, M*K - I*L ) + CALL DLACPY( 'Lower', LEN, KK, R(COLR-L,COLR-L), LDR, + $ R(COLR,COLR), LDR ) + CALL MB02CU( 'Column', KK, KK+K, L+K, NB, R(COLR,COLR), LDR, + $ DWORK(SHFR+2), (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, + $ RNK, IPVT, DWORK(PDW), ZERO, DWORK(PDW+6*L), + $ LDWORK-PDW-6*L+1, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The rank condition is (numerically) not +C satisfied. +C + INFO = 1 + RETURN + END IF + IF ( LEN.GT.KK ) THEN + CALL MB02CV( 'Column', 'NoStructure', KK, LEN-KK, KK+K, L+K, + $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), + $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, + $ R(COLR+KK,COLR), LDR, DWORK(SHFR+KK+2), + $ (N-1)*L, DWORK(PNR+SHFR+KK), (N-1)*L, + $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, + $ IERR ) + END IF + IF ( COMPQ ) THEN + CALL DLASET( 'All', K, KK, ZERO, ZERO, Q(1,COLR), LDQ ) + IF ( M.GT.1 ) THEN + CALL DLACPY( 'All', (M-1)*K, KK, Q(1,COLR-L), LDQ, + $ Q(K+1,COLR), LDQ ) + END IF + CALL MB02CV( 'Column', 'NoStructure', KK, M*K, KK+K, L+K, + $ NB, -1, R(COLR,COLR), LDR, DWORK(SHFR+2), + $ (N-1)*L, DWORK(PNR+SHFR), (N-1)*L, Q(1,COLR), + $ LDQ, DWORK(PDQ), M*K, DWORK(PNQ), M*K, + $ DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1, + $ IERR ) + END IF + LEN = LEN - L + COLR = COLR + L + SHFR = SHFR + L + 30 CONTINUE +C + DWORK(1) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of MB02JD *** + END diff --git a/mex/sources/libslicot/MB02JX.f b/mex/sources/libslicot/MB02JX.f new file mode 100644 index 000000000..c941bd446 --- /dev/null +++ b/mex/sources/libslicot/MB02JX.f @@ -0,0 +1,737 @@ + SUBROUTINE MB02JX( JOB, K, L, M, N, TC, LDTC, TR, LDTR, RNK, Q, + $ LDQ, R, LDR, JPVT, TOL1, TOL2, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a low rank QR factorization with column pivoting of a +C K*M-by-L*N block Toeplitz matrix T with blocks of size (K,L); +C specifically, +C T +C T P = Q R , +C +C where R is lower trapezoidal, P is a block permutation matrix +C and Q^T Q = I. The number of columns in R is equivalent to the +C numerical rank of T with respect to the given tolerance TOL1. +C Note that the pivoting scheme is local, i.e., only columns +C belonging to the same block in T are permuted. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the output of the routine as follows: +C = 'Q': computes Q and R; +C = 'R': only computes R. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in one block of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in one block of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in one block column of T. M >= 0. +C +C N (input) INTEGER +C The number of blocks in one block row of T. N >= 0. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC, L) +C The leading M*K-by-L part of this array must contain +C the first block column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. +C LDTC >= MAX(1,M*K). +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,(N-1)*L) +C The leading K-by-(N-1)*L part of this array must contain +C the first block row of T without the leading K-by-L +C block. +C +C LDTR INTEGER +C The leading dimension of the array TR. LDTR >= MAX(1,K). +C +C RNK (output) INTEGER +C The number of columns in R, which is equivalent to the +C numerical rank of T. +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,RNK) +C If JOB = 'Q', then the leading M*K-by-RNK part of this +C array contains the factor Q. +C If JOB = 'R', then this array is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. +C LDQ >= MAX(1,M*K), if JOB = 'Q'; +C LDQ >= 1, if JOB = 'R'. +C +C R (output) DOUBLE PRECISION array, dimension (LDR,RNK) +C The leading N*L-by-RNK part of this array contains the +C lower trapezoidal factor R. +C +C LDR INTEGER +C The leading dimension of the array R. +C LDR >= MAX(1,N*L) +C +C JPVT (output) INTEGER array, dimension (MIN(M*K,N*L)) +C This array records the column pivoting performed. +C If JPVT(j) = k, then the j-th column of T*P was +C the k-th column of T. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If TOL1 >= 0.0, the user supplied diagonal tolerance; +C if TOL1 < 0.0, a default diagonal tolerance is used. +C +C TOL2 DOUBLE PRECISION +C If TOL2 >= 0.0, the user supplied offdiagonal tolerance; +C if TOL2 < 0.0, a default offdiagonal tolerance is used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; DWORK(2) and DWORK(3) return the used values +C for TOL1 and TOL2, respectively. +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 3, ( M*K + ( N - 1 )*L )*( L + 2*K ) + 9*L +C + MAX(M*K,(N-1)*L) ), if JOB = 'Q'; +C LDWORK >= MAX( 3, ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, +C M*K*( L + 1 ) + L ), if JOB = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: due to perturbations induced by roundoff errors, or +C removal of nearly linearly dependent columns of the +C generator, the Schur algorithm encountered a +C situation where a diagonal element in the negative +C generator is larger in magnitude than the +C corresponding diagonal element in the positive +C generator (modulo TOL1); +C = 2: due to perturbations induced by roundoff errors, or +C removal of nearly linearly dependent columns of the +C generator, the Schur algorithm encountered a +C situation where diagonal elements in the positive +C and negative generator are equal in magnitude +C (modulo TOL1), but the offdiagonal elements suggest +C that these columns are not linearly dependent +C (modulo TOL2*ABS(diagonal element)). +C +C METHOD +C +C Householder transformations and modified hyperbolic rotations +C are used in the Schur algorithm [1], [2]. +C If, during the process, the hyperbolic norm of a row in the +C leading part of the generator is found to be less than or equal +C to TOL1, then this row is not reduced. If the difference of the +C corresponding columns has a norm less than or equal to TOL2 times +C the magnitude of the leading element, then this column is removed +C from the generator, as well as from R. Otherwise, the algorithm +C breaks down. TOL1 is set to norm(TC)*sqrt(eps) and TOL2 is set +C to N*L*sqrt(eps) by default. +C If M*K > L, the columns of T are permuted so that the diagonal +C elements in one block column of R have decreasing magnitudes. +C +C REFERENCES +C +C [1] Kailath, T. and Sayed, A. +C Fast Reliable Algorithms for Matrices with Structure. +C SIAM Publications, Philadelphia, 1999. +C +C [2] Kressner, D. and Van Dooren, P. +C Factorizations and linear system solvers for matrices with +C Toeplitz structure. +C SLICOT Working Note 2000-2, 2000. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(K*RNK*L*M*N) floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001. +C D. Kressner, Technical Univ. Berlin, Germany, July 2002. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Householder transformation, matrix +C operations, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, K, L, LDQ, LDR, LDTC, LDTR, LDWORK, M, N, + $ RNK + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + DOUBLE PRECISION DWORK(LDWORK), Q(LDQ,*), R(LDR,*), TC(LDTC,*), + $ TR(LDTR,*) + INTEGER JPVT(*) +C .. Local Scalars .. + LOGICAL COMPQ, LAST + INTEGER CPCOL, GAP, I, IERR, J, JJ, JWORK, KK, LEN, MK, + $ NZC, PDP, PDQ, PDW, PNQ, PNR, PP, PPR, PT, RDEF, + $ RRDF, RRNK, WRKMIN, WRKOPT + DOUBLE PRECISION LTOL1, LTOL2, NRM, TEMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEQP3, DGEQRF, DLACPY, DLASET, + $ DORGQR, DSCAL, DSWAP, DTRMV, MA02AD, MB02CU, + $ MB02CV, MB02KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + WRKOPT = 3 + MK = M*K + COMPQ = LSAME( JOB, 'Q' ) + IF ( COMPQ ) THEN + WRKMIN = MAX( 3, ( MK + ( N - 1 )*L )*( L + 2*K ) + 9*L + + $ MAX( MK, ( N - 1 )*L ) ) + ELSE + WRKMIN = MAX( 3, MAX ( ( N - 1 )*L*( L + 2*K + 1 ) + 9*L, + $ MK*( L + 1 ) + L ) ) + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( COMPQ .OR. LSAME( JOB, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( K.LT.0 ) THEN + INFO = -2 + ELSE IF ( L.LT.0 ) THEN + INFO = -3 + ELSE IF ( M.LT.0 ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDTC.LT.MAX( 1, MK ) ) THEN + INFO = -7 + ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN + INFO = -9 + ELSE IF ( LDQ.LT.1 .OR. ( COMPQ .AND. LDQ.LT.MK ) ) THEN + INFO = -12 + ELSE IF ( LDR.LT.MAX( 1, N*L ) ) THEN + INFO = -14 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = -19 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02JX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, N, K, L ).EQ.0 ) THEN + RNK = 0 + DWORK(1) = DBLE( WRKOPT ) + DWORK(2) = ZERO + DWORK(3) = ZERO + RETURN + END IF +C + WRKOPT = WRKMIN +C + IF ( MK.LE.L ) THEN +C +C Catch M*K <= L. +C + CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) + PDW = MK*L + 1 + JWORK = PDW + MK + CALL DGEQRF( MK, L, DWORK, MK, DWORK(PDW), DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + CALL MA02AD( 'Upper part', MK, L, DWORK, MK, R, LDR ) + CALL DORGQR( MK, MK, MK, DWORK, MK, DWORK(PDW), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( COMPQ ) + $ CALL DLACPY( 'All', MK, MK, DWORK, MK, Q, LDQ ) + PDW = MK*MK + 1 + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, MK, ONE, + $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), + $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + DO 10 I = 1, MK + JPVT(I) = I + 10 CONTINUE +C + RNK = MK + DWORK(1) = DBLE( WRKOPT ) + DWORK(2) = ZERO + DWORK(3) = ZERO + RETURN + END IF +C +C Compute the generator: +C +C 1st column of the generator. +C + DO 20 I = 1, L + JPVT(I) = 0 + 20 CONTINUE +C + LTOL1 = TOL1 + LTOL2 = TOL2 +C + IF ( COMPQ ) THEN + CALL DLACPY( 'All', MK, L, TC, LDTC, Q, LDQ ) + CALL DGEQP3( MK, L, Q, LDQ, JPVT, DWORK, DWORK(L+1), + $ LDWORK-L, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) +C + IF ( LTOL1.LT.ZERO ) THEN +C +C Compute default tolerance LTOL1. +C +C Estimate the 2-norm of the first block column of the +C matrix with 5 power iterations. +C + TEMP = ONE / SQRT( DBLE( L ) ) + CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(L+1), 1 ) +C + DO 30 I = 1, 5 + CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, Q, + $ LDQ, DWORK(L+1), 1 ) + CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, Q, LDQ, + $ DWORK(L+1), 1 ) + NRM = DNRM2( L, DWORK(L+1), 1 ) + CALL DSCAL( L, ONE/NRM, DWORK(L+1), 1 ) + 30 CONTINUE +C + LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) + END IF +C + I = L +C + 40 CONTINUE + IF ( ABS( Q(I,I) ).LE.LTOL1 ) THEN + I = I - 1 + IF ( I.GT.0 ) GO TO 40 + END IF +C + RRNK = I + RRDF = L - RRNK + CALL MA02AD( 'Upper', RRNK, L, Q, LDQ, R, LDR ) + IF ( RRNK.GT.1 ) + $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) + CALL DORGQR( MK, L, RRNK, Q, LDQ, DWORK, DWORK(L+1), LDWORK-L, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(L+1) ) + L ) + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, + $ ZERO, TC, LDTC, TR, LDTR, Q, LDQ, R(L+1,1), + $ LDR, DWORK, LDWORK, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C + ELSE +C + PDW = MK*L + 1 + JWORK = PDW + L + CALL DLACPY( 'All', MK, L, TC, LDTC, DWORK, MK ) + CALL DGEQP3( MK, L, DWORK, MK, JPVT, DWORK(PDW), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + IF ( LTOL1.LT.ZERO ) THEN +C +C Compute default tolerance LTOL1. +C +C Estimate the 2-norm of the first block column of the +C matrix with 5 power iterations. +C + TEMP = ONE / SQRT( DBLE( L ) ) + CALL DLASET( 'All', L, 1, TEMP, TEMP, DWORK(JWORK), 1 ) +C + DO 50 I = 1, 5 + CALL DTRMV( 'Upper', 'NonTranspose', 'NonUnit', L, DWORK, + $ MK, DWORK(JWORK), 1 ) + CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', L, DWORK, + $ MK, DWORK(JWORK), 1 ) + NRM = DNRM2( L, DWORK(JWORK), 1 ) + CALL DSCAL( L, ONE/NRM, DWORK(JWORK), 1 ) + 50 CONTINUE +C + LTOL1 = SQRT( NRM*DLAMCH( 'Epsilon' ) ) + END IF +C + RRNK = L + I = ( L - 1 )*MK + L +C + 60 CONTINUE + IF ( ABS( DWORK(I) ).LE.LTOL1 ) THEN + RRNK = RRNK - 1 + I = I - MK - 1 + IF ( I.GT.0 ) GO TO 60 + END IF +C + RRDF = L - RRNK + CALL MA02AD( 'Upper part', RRNK, L, DWORK, MK, R, LDR ) + IF ( RRNK.GT.1 ) + $ CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(1,2), LDR ) + CALL DORGQR( MK, L, RRNK, DWORK, MK, DWORK(PDW), + $ DWORK(JWORK), LDWORK-JWORK+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( N.GT.1 ) THEN + CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, RRNK, ONE, + $ ZERO, TC, LDTC, TR, LDTR, DWORK, MK, R(L+1,1), + $ LDR, DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + END IF + END IF +C +C Quick return if N = 1. +C + IF ( N.EQ.1 ) THEN + RNK = RRNK + DWORK(1) = DBLE( WRKOPT ) + DWORK(2) = LTOL1 + DWORK(3) = ZERO + RETURN + END IF +C +C Compute default tolerance LTOL2. +C + IF ( LTOL2.LT.ZERO ) + $ LTOL2 = DBLE( N*L )*SQRT( DLAMCH( 'Epsilon' ) ) +C + DO 70 J = 1, L + CALL DCOPY( RRNK, R(J,1), LDR, R(L+JPVT(J),RRNK+1), LDR ) + 70 CONTINUE +C + IF ( N.GT.2 ) + $ CALL DLACPY( 'All', (N-2)*L, RRNK, R(L+1,1), LDR, + $ R(2*L+1,RRNK+1), LDR ) +C +C 2nd column of the generator. +C + IF ( RRDF.GT.0 ) + $ CALL MA02AD( 'All', MIN( RRDF, K ), (N-1)*L, TR, LDTR, + $ R(L+1,2*RRNK+1), LDR ) + IF ( K.GT.RRDF ) + $ CALL MA02AD( 'All', K-RRDF, (N-1)*L, TR(RRDF+1,1), LDTR, DWORK, + $ (N-1)*L ) +C +C 3rd column of the generator. +C + PNR = ( N - 1 )*L*MAX( 0, K-RRDF ) + 1 + CALL DLACPY( 'All', (N-1)*L, RRNK, R(L+1,1), LDR, DWORK(PNR), + $ (N-1)*L ) +C +C 4th column of the generator. +C + PDW = PNR + ( N - 1 )*L*RRNK + PT = ( M - 1 )*K + 1 +C + DO 80 I = 1, MIN( M, N-1 ) + CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), (N-1)*L ) + PT = PT - K + PDW = PDW + L + 80 CONTINUE +C + PT = 1 +C + DO 90 I = M + 1, N - 1 + CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), (N-1)*L ) + PT = PT + L + PDW = PDW + L + 90 CONTINUE +C + IF ( COMPQ ) THEN + PDQ = PNR + ( N - 1 )*L*( RRNK + K ) + PNQ = PDQ + MK*MAX( 0, K-RRDF ) + PDW = PNQ + MK*( RRNK + K ) + CALL DLACPY( 'All', MK, RRNK, Q, LDQ, DWORK(PNQ), MK ) + IF ( M.GT.1 ) + $ CALL DLACPY( 'All', (M-1)*K, RRNK, Q, LDQ, Q(K+1,RRNK+1), + $ LDQ ) + CALL DLASET( 'All', K, RRNK, ZERO, ZERO, Q(1,RRNK+1), LDQ ) + IF ( RRDF.GT.0 ) + $ CALL DLASET( 'All', MK, RRDF, ZERO, ONE, Q(1,2*RRNK+1), + $ LDQ ) + CALL DLASET( 'All', RRDF, MAX( 0, K-RRDF ), ZERO, ZERO, + $ DWORK(PDQ), MK ) + CALL DLASET( 'All', M*K-RRDF, MAX( 0, K-RRDF ), ZERO, ONE, + $ DWORK(PDQ+RRDF), MK ) + CALL DLASET( 'All', MK, K, ZERO, ZERO, DWORK(PNQ+MK*RRNK), MK ) + ELSE + PDW = PNR + ( N - 1 )*L*( RRNK + K ) + END IF + PPR = 1 + RNK = RRNK + RDEF = RRDF + LEN = N*L + GAP = N*L - MIN( N*L, MK ) +C +C KK is the number of columns in the leading part of the +C generator. After sufficiently many rank drops or if +C M*K < N*L it may be less than L. +C + KK = MIN( L+K-RDEF, L ) + KK = MIN( KK, MK-L ) +C +C Generator reduction process. +C + DO 190 I = L + 1, MIN( MK, N*L ), L + IF ( I+L.LE.MIN( MK, N*L ) ) THEN + LAST = .FALSE. + ELSE + LAST = .TRUE. + END IF + PP = KK + MAX( K - RDEF, 0 ) + LEN = LEN - L + CALL MB02CU( 'Deficient', KK, PP, L+K-RDEF, -1, R(I,RNK+1), + $ LDR, DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, + $ RRNK, JPVT(I), DWORK(PDW), LTOL1, DWORK(PDW+5*L), + $ LDWORK-PDW-5*L+1, IERR ) + IF ( IERR.NE.0 ) THEN +C +C Error return: The current generator is indefinite. +C + INFO = 1 + RETURN + END IF +C +C Apply pivoting to other columns of R. +C + PDP = PDW + 6*L - I +C + DO 100 J = I, I + KK - 1 + JPVT(J) = JPVT(J) + I - 1 + DWORK(PDP+JPVT(J)) = DBLE(J) + 100 CONTINUE +C + DO 120 J = I, I + KK - 1 + TEMP = DBLE(J) + JJ = J-1 +C + 110 CONTINUE + JJ = JJ + 1 + IF ( DWORK(PDP+JJ).NE.TEMP ) GO TO 110 +C + IF ( JJ.NE.J ) THEN + DWORK(PDP+JJ) = DWORK(PDP+J) + CALL DSWAP( RNK, R(J,1), LDR, R(JJ,1), LDR ) + END IF + 120 CONTINUE +C + DO 130 J = I + KK, I + L - 1 + JPVT(J) = J + 130 CONTINUE +C +C Apply reduction to other rows of R. +C + IF ( LEN.GT.KK ) THEN + CALL MB02CV( 'Deficient', 'NoStructure', KK, LEN-KK, PP, + $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, + $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, + $ R(I+KK,RNK+1), LDR, DWORK(PPR+KK), (N-1)*L, + $ DWORK(PNR+KK), (N-1)*L, DWORK(PDW), + $ DWORK(PDW+5*L), LDWORK-PDW-5*L+1, IERR ) + END IF +C +C Apply reduction to Q. +C + IF ( COMPQ ) THEN + CALL MB02CV( 'Deficient', 'NoStructure', KK, MK, PP, + $ L+K-RDEF, -1, RRNK, R(I,RNK+1), LDR, + $ DWORK(PPR), (N-1)*L, DWORK(PNR), (N-1)*L, + $ Q(1,RNK+1), LDQ, DWORK(PDQ), MK, DWORK(PNQ), + $ MK, DWORK(PDW), DWORK(PDW+5*L), + $ LDWORK-PDW-5*L+1, IERR ) + END IF +C +C Inspection of the rank deficient columns: +C Look for small diagonal entries. +C + NZC = 0 +C + DO 140 J = KK, RRNK + 1, -1 + IF ( ABS( R(I+J-1,RNK+J) ).LE.LTOL1 ) NZC = NZC + 1 + 140 CONTINUE +C +C The last NZC columns of the generator cannot be removed. +C Now, decide whether for the other rank deficient columns +C it is safe to remove. +C + PT = PNR +C + DO 150 J = RRNK + 1, KK - NZC + TEMP = R(I+J-1,RNK+J) + CALL DSCAL( LEN-J-GAP, TEMP, R(I+J,RNK+J), 1 ) + CALL DAXPY( LEN-J-GAP, -DWORK(PT+J-1), DWORK(PT+J), 1, + $ R(I+J,RNK+J), 1 ) + IF ( DNRM2( LEN-J-GAP, R(I+J,RNK+J), 1 ) + $ .GT.LTOL2*ABS( TEMP ) ) THEN +C +C Unlucky case: +C It is neither advisable to remove the whole column nor +C possible to remove the diagonal entries by Hyperbolic +C rotations. +C + INFO = 2 + RETURN + END IF + PT = PT + ( N - 1 )*L + 150 CONTINUE +C +C Annihilate unwanted elements in the factor R. +C + RRDF = KK - RRNK + CALL DLASET( 'All', I-1, RRNK, ZERO, ZERO, R(1,RNK+1), LDR ) + CALL DLASET( 'Upper', L-1, RRNK-1, ZERO, ZERO, R(I,RNK+2), + $ LDR ) +C +C Construct the generator for the next step. +C + IF ( .NOT.LAST ) THEN +C +C Compute KK for the next step. +C + KK = MIN( L+K-RDEF-RRDF+NZC, L ) + KK = MIN( KK, MK-I-L+1 ) +C + IF ( KK.LE.0 ) THEN + RNK = RNK + RRNK + GO TO 200 + END IF +C + CALL DLASET( 'All', L, RRDF, ZERO, ZERO, R(I,RNK+RRNK+1), + $ LDR ) +C +C The columns with small diagonal entries form parts of the +C new positive generator. +C + IF ( ( RRDF-NZC ).GT.0 .AND. NZC.GT.0 ) THEN + CPCOL = MIN( NZC, KK ) +C + DO 160 J = RNK + RRNK + 1, RNK + RRNK + CPCOL + CALL DCOPY( LEN-L, R(I+L,J+RRDF-NZC), 1, + $ R(I+L,J), 1 ) + 160 CONTINUE +C + END IF +C +C Construct the leading parts of the positive generator. +C + CPCOL = MIN( RRNK, KK-NZC ) + IF ( CPCOL.GT.0 ) THEN +C + DO 170 J = I, I + L - 1 + CALL DCOPY( CPCOL, R(J,RNK+1), LDR, + $ R(JPVT(J)+L,RNK+RRNK+NZC+1), LDR ) + 170 CONTINUE +C + IF ( LEN.GT.2*L ) THEN + CALL DLACPY( 'All', LEN-2*L, CPCOL, R(I+L,RNK+1), LDR, + $ R(I+2*L,RNK+RRNK+NZC+1), LDR ) + END IF + END IF + PPR = PPR + L +C +C Refill the leading parts of the positive generator. +C + CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) + IF ( CPCOL.GT.0 ) THEN + CALL DLACPY( 'All', LEN-L, CPCOL, DWORK(PPR), (N-1)*L, + $ R(I+L,RNK+2*RRNK+NZC+1), LDR ) + PPR = PPR + CPCOL*( N - 1 )*L + END IF + PNR = PNR + ( RRDF - NZC )*( N - 1 )*L + L +C +C Do the same things for Q. +C + IF ( COMPQ ) THEN + IF ( ( RRDF - NZC ).GT.0 .AND. NZC.GT.0 ) THEN + CPCOL = MIN( NZC, KK ) +C + DO 180 J = RNK + RRNK + 1, RNK + RRNK + CPCOL + CALL DCOPY( MK, Q(1,J+RRDF-NZC), 1, Q(1,J), 1 ) + 180 CONTINUE +C + END IF + CPCOL = MIN( RRNK, KK-NZC ) + IF ( CPCOL.GT.0 ) THEN + CALL DLASET( 'All', K, CPCOL, ZERO, ZERO, + $ Q(1,RNK+RRNK+NZC+1), LDQ ) + IF ( M.GT.1 ) + $ CALL DLACPY( 'All', (M-1)*K, CPCOL, Q(1,RNK+1), + $ LDQ, Q(K+1,RNK+RRNK+NZC+1), LDQ ) + END IF + CPCOL = MIN( K-RDEF, KK-RRNK-NZC ) + IF ( CPCOL.GT.0 ) THEN + CALL DLACPY( 'All', MK, CPCOL, DWORK(PDQ), MK, + $ Q(1,RNK+2*RRNK+NZC+1), LDQ ) + PDQ = PDQ + CPCOL*MK + END IF + PNQ = PNQ + ( RRDF - NZC )*MK + END IF + END IF + RNK = RNK + RRNK + RDEF = RDEF + RRDF - NZC + 190 CONTINUE +C + 200 CONTINUE + DWORK(1) = DBLE( WRKOPT ) + DWORK(2) = LTOL1 + DWORK(3) = LTOL2 +C +C *** Last line of MB02JX *** + END diff --git a/mex/sources/libslicot/MB02KD.f b/mex/sources/libslicot/MB02KD.f new file mode 100644 index 000000000..c45c7cd62 --- /dev/null +++ b/mex/sources/libslicot/MB02KD.f @@ -0,0 +1,842 @@ + SUBROUTINE MB02KD( LDBLK, TRANS, K, L, M, N, R, ALPHA, BETA, + $ TC, LDTC, TR, LDTR, B, LDB, C, LDC, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix product +C +C C = alpha*op( T )*B + beta*C, +C +C where alpha and beta are scalars and T is a block Toeplitz matrix +C specified by its first block column TC and first block row TR; +C B and C are general matrices of appropriate dimensions. +C +C ARGUMENTS +C +C Mode Parameters +C +C LDBLK CHARACTER*1 +C Specifies where the (1,1)-block of T is stored, as +C follows: +C = 'C': in the first block of TC; +C = 'R': in the first block of TR. +C +C TRANS CHARACTER*1 +C Specifies the form of op( T ) to be used in the matrix +C multiplication as follows: +C = 'N': op( T ) = T; +C = 'T': op( T ) = T'; +C = 'C': op( T ) = T'. +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of rows in the blocks of T. K >= 0. +C +C L (input) INTEGER +C The number of columns in the blocks of T. L >= 0. +C +C M (input) INTEGER +C The number of blocks in the first block column of T. +C M >= 0. +C +C N (input) INTEGER +C The number of blocks in the first block row of T. N >= 0. +C +C R (input) INTEGER +C The number of columns in B and C. R >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then TC, TR and B +C are not referenced. +C +C BETA (input) DOUBLE PRECISION +C The scalar beta. When beta is zero then C need not be set +C before entry. +C +C TC (input) DOUBLE PRECISION array, dimension (LDTC,L) +C On entry with LDBLK = 'C', the leading M*K-by-L part of +C this array must contain the first block column of T. +C On entry with LDBLK = 'R', the leading (M-1)*K-by-L part +C of this array must contain the 2nd to the M-th blocks of +C the first block column of T. +C +C LDTC INTEGER +C The leading dimension of the array TC. +C LDTC >= MAX(1,M*K), if LDBLK = 'C'; +C LDTC >= MAX(1,(M-1)*K), if LDBLK = 'R'. +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,k) +C where k is (N-1)*L when LDBLK = 'C' and is N*L when +C LDBLK = 'R'. +C On entry with LDBLK = 'C', the leading K-by-(N-1)*L part +C of this array must contain the 2nd to the N-th blocks of +C the first block row of T. +C On entry with LDBLK = 'R', the leading K-by-N*L part of +C this array must contain the first block row of T. +C +C LDTR INTEGER +C The leading dimension of the array TR. LDTR >= MAX(1,K). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,R) +C On entry with TRANS = 'N', the leading N*L-by-R part of +C this array must contain the matrix B. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C M*K-by-R part of this array must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N*L), if TRANS = 'N'; +C LDB >= MAX(1,M*K), if TRANS = 'T' or TRANS = 'C'. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,R) +C On entry with TRANS = 'N', the leading M*K-by-R part of +C this array must contain the matrix C. +C On entry with TRANS = 'T' or TRANS = 'C', the leading +C N*L-by-R part of this array must contain the matrix C. +C On exit with TRANS = 'N', the leading M*K-by-R part of +C this array contains the updated matrix C. +C On exit with TRANS = 'T' or TRANS = 'C', the leading +C N*L-by-R part of this array contains the updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= MAX(1,M*K), if TRANS = 'N'; +C LDC >= MAX(1,N*L), if TRANS = 'T' or TRANS = 'C'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C For point Toeplitz matrices or sufficiently large block Toeplitz +C matrices, this algorithm uses convolution algorithms based on +C the fast Hartley transforms [1]. Otherwise, TC is copied in +C reversed order into the workspace such that C can be computed from +C barely M matrix-by-matrix multiplications. +C +C REFERENCES +C +C [1] Van Loan, Charles. +C Computational frameworks for the fast Fourier transform. +C SIAM, 1992. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O( (K*L+R*L+K*R)*(N+M)*log(N+M) + K*L*R ) +C floating point operations. +C +C CONTRIBUTOR +C +C D. Kressner, Technical Univ. Berlin, Germany, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, June 2001, +C March 2004. +C +C KEYWORDS +C +C Convolution, elementary matrix operations, +C fast Hartley transform, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, THOM50 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0, FOUR = 4.0D0, THOM50 = .95D3 ) +C .. Scalar Arguments .. + CHARACTER LDBLK, TRANS + INTEGER INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N, + $ R + DOUBLE PRECISION ALPHA, BETA +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), C(LDC,*), DWORK(*), TC(LDTC,*), + $ TR(LDTR,*) +C .. Local Scalars .. + LOGICAL FULLC, LMULT, LTRAN + CHARACTER*1 WGHT + INTEGER DIMB, DIMC, I, ICP, ICQ, IERR, IR, J, JJ, KK, + $ LEN, LL, LN, METH, MK, NL, P, P1, P2, PB, PC, + $ PDW, PP, PT, Q1, Q2, R1, R2, S1, S2, SHFT, WPOS, + $ WRKOPT + DOUBLE PRECISION CF, COEF, PARAM, SCAL, SF, T1, T2, TH +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DG01OD, DGEMM, DLACPY, DLASET, + $ DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, COS, DBLE, MAX, MIN, SIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + FULLC = LSAME( LDBLK, 'C' ) + LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + LMULT = ALPHA.NE.ZERO + MK = M*K + NL = N*L +C +C Check the scalar input parameters. +C + IF ( .NOT.( FULLC .OR. LSAME( LDBLK, 'R' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( K.LT.0 ) THEN + INFO = -3 + ELSE IF ( L.LT.0 ) THEN + INFO = -4 + ELSE IF ( M.LT.0 ) THEN + INFO = -5 + ELSE IF ( N.LT.0 ) THEN + INFO = -6 + ELSE IF ( R.LT.0 ) THEN + INFO = -7 + ELSE IF ( LMULT .AND. FULLC .AND. LDTC.LT.MAX( 1, MK ) ) THEN + INFO = -11 + ELSE IF ( LMULT .AND. .NOT.FULLC .AND. + $ LDTC.LT.MAX( 1,( M - 1 )*K ) ) THEN + INFO = -11 + ELSE IF ( LMULT .AND. LDTR.LT.MAX( 1, K ) ) THEN + INFO = -13 + ELSE IF ( LMULT .AND. .NOT.LTRAN .AND. LDB.LT.MAX( 1, NL ) ) THEN + INFO = -15 + ELSE IF ( LMULT .AND. LTRAN .AND. LDB.LT.MAX( 1, MK ) ) THEN + INFO = -15 + ELSE IF ( .NOT.LTRAN .AND. LDC.LT.MAX( 1, MK ) ) THEN + INFO = -17 + ELSE IF ( LTRAN .AND. LDC.LT.MAX( 1, NL ) ) THEN + INFO = -17 + ELSE IF ( LDWORK.LT.1 ) THEN + DWORK(1) = ONE + INFO = -19 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02KD', -INFO ) + RETURN + END IF +C +C Scale C beforehand. +C + IF ( BETA.EQ.ZERO ) THEN + IF ( LTRAN ) THEN + CALL DLASET( 'All', NL, R, ZERO, ZERO, C, LDC ) + ELSE + CALL DLASET( 'All', MK, R, ZERO, ZERO, C, LDC ) + END IF + ELSE IF ( BETA.NE.ONE ) THEN + IF ( LTRAN ) THEN +C + DO 10 I = 1, R + CALL DSCAL( NL, BETA, C(1,I), 1 ) + 10 CONTINUE +C + ELSE +C + DO 20 I = 1, R + CALL DSCAL( MK, BETA, C(1,I), 1 ) + 20 CONTINUE +C + END IF + END IF +C +C Quick return if possible. +C + IF ( .NOT.LMULT .OR. MIN( MK, NL, R ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C The parameter PARAM is the watershed between conventional +C multiplication and convolution. This is of course depending +C on the used computer architecture. The lower this value is set +C the more likely the routine will use convolution to compute +C op( T )*B. Note that if there is enough workspace available, +C convolution is always used for point Toeplitz matrices. +C + PARAM = THOM50 +C +C Decide which method to choose, based on the block sizes and +C the available workspace. +C + LEN = 1 + P = 0 +C + 30 CONTINUE + IF ( LEN.LT.M+N-1 ) THEN + LEN = LEN*2 + P = P + 1 + GO TO 30 + END IF +C + COEF = THREE*DBLE( M*N )*DBLE( K*L )*DBLE( R ) / + $ DBLE( LEN*( K*L + L*R + K*R ) ) +C + IF ( FULLC ) THEN + P1 = MK*L + SHFT = 0 + ELSE + P1 = ( M - 1 )*K*L + SHFT = 1 + END IF + IF ( K*L.EQ.1 .AND. MIN( M, N ).GT.1 ) THEN + WRKOPT = LEN*( 2 + R ) - P + METH = 3 + ELSE IF ( ( LEN.LT.M*N ) .AND. ( COEF.GE.PARAM ) ) THEN + WRKOPT = LEN*( K*L + K*R + L*R + 1 ) - P + METH = 3 + ELSE + METH = 2 + WRKOPT = P1 + END IF +C + IF ( LDWORK.LT.WRKOPT ) METH = METH - 1 + IF ( LDWORK.LT.P1 ) METH = 1 +C +C Start computations. +C + IF ( METH.EQ.1 .AND. .NOT.LTRAN ) THEN +C +C Method 1 is the most unlucky way to multiply Toeplitz matrices +C with vectors. Due to the memory restrictions it is not +C possible to flip TC. +C + PC = 1 +C + DO 50 I = 1, M + PT = ( I - 1 - SHFT )*K + 1 + PB = 1 +C + DO 40 J = SHFT + 1, I + CALL DGEMM( 'No Transpose', 'No Transpose', K, R, L, + $ ALPHA, TC(PT,1), LDTC, B(PB,1), LDB, ONE, + $ C(PC,1), LDC ) + PT = PT - K + PB = PB + L + 40 CONTINUE +C + IF ( N.GT.I-SHFT ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', K, R, + $ (N-I+SHFT)*L, ALPHA, TR, LDTR, B(PB,1), LDB, + $ ONE, C(PC,1), LDC ) + END IF + PC = PC + K + 50 CONTINUE +C + ELSE IF ( METH.EQ.1 .AND. LTRAN ) THEN +C + PB = 1 +C + DO 70 I = 1, M + PT = ( I - 1 - SHFT )*K + 1 + PC = 1 +C + DO 60 J = SHFT + 1, I + CALL DGEMM( 'Transpose', 'No Transpose', L, R, K, ALPHA, + $ TC(PT,1), LDTC, B(PB,1), LDB, ONE, C(PC,1), + $ LDC ) + PT = PT - K + PC = PC + L + 60 CONTINUE +C + IF ( N.GT.I-SHFT ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, + $ R, K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, + $ C(PC,1), LDC ) + END IF + PB = PB + K + 70 CONTINUE +C + ELSE IF ( METH.EQ.2 .AND. .NOT.LTRAN ) THEN +C +C In method 2 TC is flipped resulting in less calls to the BLAS +C routine DGEMM. Actually this seems often to be the best way to +C multiply with Toeplitz matrices except the point Toeplitz +C case. +C + PT = ( M - 1 - SHFT )*K + 1 +C + DO 80 I = 1, ( M - SHFT )*K*L, K*L + CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) + PT = PT - K + 80 CONTINUE +C + PT = ( M - 1 )*K*L + 1 + PC = 1 +C + DO 90 I = 1, M + CALL DGEMM( 'No Transpose', 'No Transpose', K, R, + $ MIN( I-SHFT, N )*L, ALPHA, DWORK(PT), K, B, LDB, + $ ONE, C(PC,1), LDC ) + IF ( N.GT.I-SHFT ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', K, R, + $ (N-I+SHFT)*L, ALPHA, TR, LDTR, + $ B((I-SHFT)*L+1,1), LDB, ONE, C(PC,1), LDC ) + END IF + PC = PC + K + PT = PT - K*L + 90 CONTINUE +C + ELSE IF ( METH.EQ.2 .AND. LTRAN ) THEN +C + PT = ( M - 1 - SHFT )*K + 1 +C + DO 100 I = 1, ( M - SHFT )*K*L, K*L + CALL DLACPY( 'All', K, L, TC(PT,1), LDTC, DWORK(I), K ) + PT = PT - K + 100 CONTINUE +C + PT = ( M - 1 )*K*L + 1 + PB = 1 +C + DO 110 I = 1, M + CALL DGEMM( 'Tranpose', 'No Transpose', MIN( I-SHFT, N )*L, + $ R, K, ALPHA, DWORK(PT), K, B(PB,1), LDB, ONE, + $ C, LDC ) + IF ( N.GT.I-SHFT ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', (N-I+SHFT)*L, R, + $ K, ALPHA, TR, LDTR, B(PB,1), LDB, ONE, + $ C((I-SHFT)*L+1,1), LDC ) + END IF + PB = PB + K + PT = PT - K*L + 110 CONTINUE +C + ELSE IF ( METH.EQ.3 ) THEN +C +C In method 3 the matrix-vector product is computed by a suitable +C block convolution via fast Hartley transforms similar to the +C SLICOT routine DE01PD. +C +C Step 1: Copy input data into the workspace arrays. +C + PDW = 1 + IF ( LTRAN ) THEN + DIMB = K + DIMC = L + ELSE + DIMB = L + DIMC = K + END IF + PB = LEN*K*L + PC = LEN*( K*L + DIMB*R ) + IF ( LTRAN ) THEN + IF ( FULLC ) THEN + CALL DLACPY( 'All', K, L, TC, LDTC, DWORK, LEN*K ) + END IF +C + DO 120 I = 1, N - 1 + SHFT + CALL DLACPY( 'All', K, L, TR(1,(I-1)*L+1), LDTR, + $ DWORK((I-SHFT)*K+1), LEN*K ) + 120 CONTINUE +C + PDW = N*K + 1 + R1 = ( LEN - M - N + 1 )*K + CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) + PDW = PDW + R1 +C + DO 130 I = ( M - 1 - SHFT )*K + 1, K - SHFT*K + 1, -K + CALL DLACPY( 'All', K, L, TC(I,1), LDTC, + $ DWORK(PDW), LEN*K ) + PDW = PDW + K + 130 CONTINUE +C + PDW = PB + 1 + CALL DLACPY( 'All', MK, R, B, LDB, DWORK(PDW), LEN*K ) + PDW = PDW + MK + CALL DLASET( 'All', (LEN-M)*K, R, ZERO, ZERO, DWORK(PDW), + $ LEN*K ) + ELSE + IF ( .NOT.FULLC ) THEN + CALL DLACPY( 'All', K, L, TR, LDTR, DWORK, LEN*K ) + END IF + CALL DLACPY( 'All', (M-SHFT)*K, L, TC, LDTC, + $ DWORK(SHFT*K+1), LEN*K ) + PDW = MK + 1 + R1 = ( LEN - M - N + 1 )*K + CALL DLASET( 'All', R1, L, ZERO, ZERO, DWORK(PDW), LEN*K ) + PDW = PDW + R1 +C + DO 140 I = ( N - 2 + SHFT )*L + 1, SHFT*L + 1, -L + CALL DLACPY( 'All', K, L, TR(1,I), LDTR, DWORK(PDW), + $ LEN*K ) + PDW = PDW + K + 140 CONTINUE +C + PDW = PB + 1 + CALL DLACPY( 'All', NL, R, B, LDB, DWORK(PDW), LEN*L ) + PDW = PDW + NL + CALL DLASET( 'All', (LEN-N)*L, R, ZERO, ZERO, DWORK(PDW), + $ LEN*L ) + END IF +C +C Take point Toeplitz matrices into extra consideration. +C + IF ( K*L.EQ.1 ) THEN + WGHT = 'N' + CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK, + $ DWORK(PC+1), IERR ) +C + DO 170 I = PB, PB + LEN*R - 1, LEN + CALL DG01OD( 'OutputScrambled', WGHT, LEN, DWORK(I+1), + $ DWORK(PC+1), IERR ) + SCAL = ALPHA / DBLE( LEN ) + DWORK(I+1) = SCAL*DWORK(I+1)*DWORK(1) + DWORK(I+2) = SCAL*DWORK(I+2)*DWORK(2) + SCAL = SCAL / TWO +C + LN = 1 +C + DO 160 LL = 1, P - 1 + LN = 2*LN + R1 = 2*LN +C + DO 150 P1 = LN + 1, LN + LN/2 + T1 = DWORK(P1) + DWORK(R1) + T2 = DWORK(P1) - DWORK(R1) + TH = T2*DWORK(I+P1) + DWORK(I+P1) = SCAL*( T1*DWORK(I+P1) + $ + T2*DWORK(I+R1) ) + DWORK(I+R1) = SCAL*( T1*DWORK(I+R1) - TH ) + R1 = R1 - 1 + 150 CONTINUE +C + 160 CONTINUE +C + CALL DG01OD( 'InputScrambled', WGHT, LEN, DWORK(I+1), + $ DWORK(PC+1), IERR ) + 170 CONTINUE +C + PC = PB + GOTO 420 + END IF +C +C Step 2: Compute the weights for the Hartley transforms. +C + PDW = PC + R1 = 1 + LN = 1 + TH = FOUR*ATAN( ONE ) / DBLE( LEN ) +C + DO 190 LL = 1, P - 2 + LN = 2*LN + TH = TWO*TH + CF = COS( TH ) + SF = SIN( TH ) + DWORK(PDW+R1) = CF + DWORK(PDW+R1+1) = SF + R1 = R1 + 2 +C + DO 180 I = 1, LN-2, 2 + DWORK(PDW+R1) = CF*DWORK(PDW+I) - SF*DWORK(PDW+I+1) + DWORK(PDW+R1+1) = SF*DWORK(PDW+I) + CF*DWORK(PDW+I+1) + R1 = R1 + 2 + 180 CONTINUE +C + 190 CONTINUE +C + P1 = 3 + Q1 = R1 - 2 +C + DO 210 LL = P - 2, 1, -1 +C + DO 200 I = P1, Q1, 4 + DWORK(PDW+R1) = DWORK(PDW+I) + DWORK(PDW+R1+1) = DWORK(PDW+I+1) + R1 = R1 + 2 + 200 CONTINUE +C + P1 = Q1 + 4 + Q1 = R1 - 2 + 210 CONTINUE +C +C Step 3: Compute the Hartley transforms with scrambled output. +C + J = 0 + KK = K +C +C WHILE J < (L*LEN*K + R*LEN*DIMB), +C + 220 CONTINUE +C + LN = LEN + WPOS = PDW+1 +C + DO 270 PP = P - 1, 1, -1 + LN = LN / 2 + P2 = 1 + Q2 = LN*KK + 1 + R2 = ( LN/2 )*KK + 1 + S2 = R2 + Q2 - 1 +C + DO 260 I = 0, LEN/( 2*LN ) - 1 +C + DO 230 IR = 0, KK - 1 + T1 = DWORK(Q2+IR+J) + DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 + DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 + T1 = DWORK(S2+IR+J) + DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 + DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 + 230 CONTINUE +C + P1 = P2 + KK + Q1 = P1 + LN*KK + R1 = Q1 - 2*KK + S1 = R1 + LN*KK +C + DO 250 JJ = WPOS, WPOS + LN - 3, 2 + CF = DWORK(JJ) + SF = DWORK(JJ+1) +C + DO 240 IR = 0, KK-1 + T1 = DWORK(P1+IR+J) - DWORK(Q1+IR+J) + T2 = DWORK(R1+IR+J) - DWORK(S1+IR+J) + DWORK(P1+IR+J) = DWORK(P1+IR+J) + + $ DWORK(Q1+IR+J) + DWORK(R1+IR+J) = DWORK(R1+IR+J) + + $ DWORK(S1+IR+J) + DWORK(Q1+IR+J) = CF*T1 + SF*T2 + DWORK(S1+IR+J) = -CF*T2 + SF*T1 + 240 CONTINUE +C + P1 = P1 + KK + Q1 = Q1 + KK + R1 = R1 - KK + S1 = S1 - KK + 250 CONTINUE +C + P2 = P2 + 2*KK*LN + Q2 = Q2 + 2*KK*LN + R2 = R2 + 2*KK*LN + S2 = S2 + 2*KK*LN + 260 CONTINUE +C + WPOS = WPOS + LN - 2 + 270 CONTINUE +C + DO 290 ICP = KK + 1, LEN*KK, 2*KK + ICQ = ICP - KK +C + DO 280 IR = 0, KK - 1 + T1 = DWORK(ICP+IR+J) + DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 + DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 + 280 CONTINUE +C + 290 CONTINUE +C + J = J + LEN*KK + IF ( J.EQ.L*LEN*K ) THEN + KK = DIMB + END IF + IF ( J.LT.PC ) GOTO 220 +C END WHILE 220 +C +C Step 4: Compute a Hadamard like product. +C + CALL DCOPY( LEN-P, DWORK(PDW+1), 1,DWORK(PDW+1+R*LEN*DIMC), 1 ) + PDW = PDW + R*LEN*DIMC + SCAL = ALPHA / DBLE( LEN ) + P1 = 1 + R1 = LEN*K*L + 1 + S1 = R1 + LEN*DIMB*R + IF ( LTRAN ) THEN + KK = L + LL = K + ELSE + KK = K + LL = L + END IF + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), + $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), + $ LEN*DIMC ) + P1 = P1 + K + R1 = R1 + DIMB + S1 = S1 + DIMC + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, DWORK(P1), + $ LEN*K, DWORK(R1), LEN*DIMB, ZERO, DWORK(S1), + $ LEN*DIMC ) + SCAL = SCAL / TWO + LN = 1 +C + DO 330 PP = 1, P - 1 + LN = 2*LN + P2 = ( 2*LN - 1 )*K + 1 + R1 = PB + LN*DIMB + 1 + R2 = PB + ( 2*LN - 1 )*DIMB + 1 + S1 = PC + LN*DIMC + 1 + S2 = PC + ( 2*LN - 1 )*DIMC + 1 +C + DO 320 P1 = LN*K + 1, ( LN + LN/2 )*K, K +C + DO 310 J = 0, LEN*K*( L - 1 ), LEN*K +C + DO 300 I = P1, P1 + K - 1 + T1 = DWORK(P2) + DWORK(P2) = DWORK(J+I) - T1 + DWORK(J+I) = DWORK(J+I) + T1 + P2 = P2 + 1 + 300 CONTINUE +C + P2 = P2 + ( LEN - 1 )*K + 310 CONTINUE +C + P2 = P2 - LEN*K*L + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, + $ DWORK(P1), LEN*K, DWORK(R1), LEN*DIMB, + $ ZERO, DWORK(S1), LEN*DIMC ) + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, + $ DWORK(P2), LEN*K, DWORK(R2), LEN*DIMB, ONE, + $ DWORK(S1), LEN*DIMC ) + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, SCAL, + $ DWORK(P1), LEN*K, DWORK(R2), LEN*DIMB, ZERO, + $ DWORK(S2), LEN*DIMC ) + CALL DGEMM( TRANS, 'No Transpose', KK, R, LL, -SCAL, + $ DWORK(P2), LEN*K, DWORK(R1), LEN*DIMB, ONE, + $ DWORK(S2), LEN*DIMC ) + P2 = P2 - K + R1 = R1 + DIMB + R2 = R2 - DIMB + S1 = S1 + DIMC + S2 = S2 - DIMC + 320 CONTINUE +C + 330 CONTINUE +C +C Step 5: Hartley transform with scrambled input. +C + DO 410 J = PC, PC + LEN*DIMC*R, LEN*DIMC +C + DO 350 ICP = DIMC + 1, LEN*DIMC, 2*DIMC + ICQ = ICP - DIMC +C + DO 340 IR = 0, DIMC - 1 + T1 = DWORK(ICP+IR+J) + DWORK(ICP+IR+J) = DWORK(ICQ+IR+J) - T1 + DWORK(ICQ+IR+J) = DWORK(ICQ+IR+J) + T1 + 340 CONTINUE +C + 350 CONTINUE +C + LN = 1 + WPOS = PDW + LEN - 2*P + 1 +C + DO 400 PP = 1, P - 1 + LN = 2*LN + P2 = 1 + Q2 = LN*DIMC + 1 + R2 = ( LN/2 )*DIMC + 1 + S2 = R2 + Q2 - 1 +C + DO 390 I = 0, LEN/( 2*LN ) - 1 +C + DO 360 IR = 0, DIMC - 1 + T1 = DWORK(Q2+IR +J) + DWORK(Q2+IR+J) = DWORK(P2+IR+J) - T1 + DWORK(P2+IR+J) = DWORK(P2+IR+J) + T1 + T1 = DWORK(S2+IR+J) + DWORK(S2+IR+J) = DWORK(R2+IR+J) - T1 + DWORK(R2+IR+J) = DWORK(R2+IR+J) + T1 + 360 CONTINUE +C + P1 = P2 + DIMC + Q1 = P1 + LN*DIMC + R1 = Q1 - 2*DIMC + S1 = R1 + LN*DIMC +C + DO 380 JJ = WPOS, WPOS + LN - 3, 2 + CF = DWORK(JJ) + SF = DWORK(JJ+1) +C + DO 370 IR = 0, DIMC - 1 + T1 = CF*DWORK(Q1+IR+J) + SF*DWORK(S1+IR+J) + T2 = -CF*DWORK(S1+IR+J) + SF*DWORK(Q1+IR+J) + DWORK(Q1+IR+J) = DWORK(P1+IR+J) - T1 + DWORK(P1+IR+J) = DWORK(P1+IR+J) + T1 + DWORK(S1+IR+J) = DWORK(R1+IR+J) - T2 + DWORK(R1+IR+J) = DWORK(R1+IR+J) + T2 + 370 CONTINUE +C + P1 = P1 + DIMC + Q1 = Q1 + DIMC + R1 = R1 - DIMC + S1 = S1 - DIMC + 380 CONTINUE +C + P2 = P2 + 2*DIMC*LN + Q2 = Q2 + 2*DIMC*LN + R2 = R2 + 2*DIMC*LN + S2 = S2 + 2*DIMC*LN + 390 CONTINUE +C + WPOS = WPOS - 2*LN + 2 + 400 CONTINUE +C + 410 CONTINUE +C +C Step 6: Copy data from workspace to output. +C + 420 CONTINUE +C + IF ( LTRAN ) THEN + I = NL + ELSE + I = MK + END IF +C + DO 430 J = 0, R - 1 + CALL DAXPY( I, ONE, DWORK(PC+(J*LEN*DIMC) + 1), 1, + $ C(1,J+1), 1 ) + 430 CONTINUE +C + END IF + DWORK(1) = DBLE( MAX( 1, WRKOPT ) ) + RETURN +C +C *** Last line of MB02KD *** + END diff --git a/mex/sources/libslicot/MB02MD.f b/mex/sources/libslicot/MB02MD.f new file mode 100644 index 000000000..28cbdadaa --- /dev/null +++ b/mex/sources/libslicot/MB02MD.f @@ -0,0 +1,577 @@ + SUBROUTINE MB02MD( JOB, M, N, L, RANK, C, LDC, S, X, LDX, TOL, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the Total Least Squares (TLS) problem using a Singular +C Value Decomposition (SVD) approach. +C The TLS problem assumes an overdetermined set of linear equations +C AX = B, where both the data matrix A as well as the observation +C matrix B are inaccurate. The routine also solves determined and +C underdetermined sets of equations by computing the minimum norm +C solution. +C It is assumed that all preprocessing measures (scaling, coordinate +C transformations, whitening, ... ) of the data have been performed +C in advance. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Determines whether the values of the parameters RANK and +C TOL are to be specified by the user or computed by the +C routine as follows: +C = 'R': Compute RANK only; +C = 'T': Compute TOL only; +C = 'B': Compute both RANK and TOL; +C = 'N': Compute neither RANK nor TOL. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in the data matrix A and the +C observation matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns in the data matrix A. N >= 0. +C +C L (input) INTEGER +C The number of columns in the observation matrix B. +C L >= 0. +C +C RANK (input/output) INTEGER +C On entry, if JOB = 'T' or JOB = 'N', then RANK must +C specify r, the rank of the TLS approximation [A+DA|B+DB]. +C RANK <= min(M,N). +C Otherwise, r is computed by the routine. +C On exit, if JOB = 'R' or JOB = 'B', and INFO = 0, then +C RANK contains the computed (effective) rank of the TLS +C approximation [A+DA|B+DB]. +C Otherwise, the user-supplied value of RANK may be +C changed by the routine on exit if the RANK-th and the +C (RANK+1)-th singular values of C = [A|B] are considered +C to be equal, or if the upper triangular matrix F (as +C defined in METHOD) is (numerically) singular. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) +C On entry, the leading M-by-(N+L) part of this array must +C contain the matrices A and B. Specifically, the first N +C columns must contain the data matrix A and the last L +C columns the observation matrix B (right-hand sides). +C On exit, the leading (N+L)-by-(N+L) part of this array +C contains the (transformed) right singular vectors, +C including null space vectors, if any, of C = [A|B]. +C Specifically, the leading (N+L)-by-RANK part of this array +C always contains the first RANK right singular vectors, +C corresponding to the largest singular values of C. If +C L = 0, or if RANK = 0 and IWARN <> 2, the remaining +C (N+L)-by-(N+L-RANK) top-right part of this array contains +C the remaining N+L-RANK right singular vectors. Otherwise, +C this part contains the matrix V2 transformed as described +C in Step 3 of the TLS algorithm (see METHOD). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= max(1,M,N+L). +C +C S (output) DOUBLE PRECISION array, dimension (min(M,N+L)) +C If INFO = 0, the singular values of matrix C, ordered +C such that S(1) >= S(2) >= ... >= S(p-1) >= S(p) >= 0, +C where p = min(M,N+L). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,L) +C If INFO = 0, the leading N-by-L part of this array +C contains the solution X to the TLS problem specified +C by A and B. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= max(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance used to determine the rank of the TLS +C approximation [A+DA|B+DB] and to check the multiplicity +C of the singular values of matrix C. Specifically, S(i) +C and S(j) (i < j) are considered to be equal if +C SQRT(S(i)**2 - S(j)**2) <= TOL, and the TLS approximation +C [A+DA|B+DB] has rank r if S(i) > TOL*S(1) (or S(i) > TOL, +C if TOL specifies sdev (see below)), for i = 1,2,...,r. +C TOL is also used to check the singularity of the upper +C triangular matrix F (as defined in METHOD). +C If JOB = 'R' or JOB = 'N', then TOL must specify the +C desired tolerance. If the user sets TOL to be less than or +C equal to 0, the tolerance is taken as EPS, where EPS is +C the machine precision (see LAPACK Library routine DLAMCH). +C Otherwise, the tolerance is computed by the routine and +C the user must supply the non-negative value sdev, i.e. the +C estimated standard deviation of the error on each element +C of the matrix C, as input value of TOL. +C +C Workspace +C +C IWORK INTEGER array, dimension (L) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2) returns the reciprocal of the +C condition number of the matrix F. +C If INFO > 0, DWORK(1:min(M,N+L)-1) contain the unconverged +C non-diagonal elements of the bidiagonal matrix whose +C diagonal is in S (see LAPACK Library routine DGESVD). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = max(2, 3*(N+L) + M, 5*(N+L)), if M >= N+L; +C LDWORK = max(2, M*(N+L) + max( 3M+N+L, 5*M), 3*L), +C if M < N+L. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warnings; +C = 1: if the rank of matrix C has been lowered because a +C singular value of multiplicity greater than 1 was +C found; +C = 2: if the rank of matrix C has been lowered because the +C upper triangular matrix F is (numerically) singular. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if the SVD algorithm (in LAPACK Library routine +C DBDSQR) has failed to converge. In this case, S(1), +C S(2), ..., S(INFO) may not have been found +C correctly and the remaining singular values may +C not be the smallest. This failure is not likely +C to occur. +C +C METHOD +C +C The method used is an extension (see [3,4,5]) of the classical +C TLS algorithm proposed by Golub and Van Loan [1]. +C +C Let [A|B] denote the matrix formed by adjoining the columns of B +C to the columns of A on the right. +C +C Total Least Squares (TLS) definition: +C ------------------------------------- +C +C Given matrices A and B, find a matrix X satisfying +C +C (A + DA) X = B + DB, +C +C where A and DA are M-by-N matrices, B and DB are M-by-L matrices +C and X is an N-by-L matrix. +C The solution X must be such that the Frobenius norm of [DA|DB] +C is a minimum and each column of B + DB is in the range of +C A + DA. Whenever the solution is not unique, the routine singles +C out the minimum norm solution X. +C +C Define matrix C = [A|B] and s(i) as its i-th singular value for +C i = 1,2,...,min(M,NL), where NL = N + L. If M < NL, then s(j) = 0 +C for j = M+1,...,NL. +C +C The Classical TLS algorithm proceeds as follows (see [3,4,5]): +C +C Step 1: Compute part of the singular value decomposition (SVD) +C USV' of C = [A|B], namely compute S and V'. (An initial +C QR factorization of C is used when M is larger enough +C than NL.) +C +C Step 2: If not fixed by the user, compute the rank r0 of the data +C [A|B] based on TOL as follows: if JOB = 'R' or JOB = 'N', +C +C s(1) >= ... >= s(r0) > TOL*s(1) >= ... >= s(NL). +C +C Otherwise, using [2], TOL can be computed from the +C standard deviation sdev of the errors on [A|B]: +C +C TOL = SQRT(2 * max(M,NL)) * sdev, +C +C and the rank r0 is determined (if JOB = 'R' or 'B') using +C +C s(1) >= ... >= s(r0) > TOL >= ... >= s(NL). +C +C The rank r of the approximation [A+DA|B+DB] is then equal +C to the minimum of N and r0. +C +C Step 3: Let V2 be the matrix of the columns of V corresponding to +C the (NL - r) smallest singular values of C, i.e. the last +C (NL - r) columns of V. +C Compute with Householder transformations the orthogonal +C matrix Q such that: +C +C |VH Y| +C V2 x Q = | | +C |0 F| +C +C where VH is an N-by-(N - r) matrix, Y is an N-by-L matrix +C and F is an L-by-L upper triangular matrix. +C If F is singular, then lower the rank r with the +C multiplicity of s(r) and repeat this step. +C +C Step 4: If F is nonsingular then the solution X is obtained by +C solving the following equations by forward elimination: +C +C X F = -Y. +C +C Notes : +C The TLS solution is unique if r = N, F is nonsingular and +C s(N) > s(N+1). +C If F is singular, however, then the computed solution is infinite +C and hence does not satisfy the second TLS criterion (see TLS +C definition). For these cases, Golub and Van Loan [1] claim that +C the TLS problem has no solution. The properties of these so-called +C nongeneric problems are described in [4] and the TLS computations +C are generalized in order to solve them. As proven in [4], the +C proposed generalization satisfies the TLS criteria for any +C number L of observation vectors in B provided that, in addition, +C the solution | X| is constrained to be orthogonal to all vectors +C |-I| +C of the form |w| which belong to the space generated by the columns +C |0| +C of the submatrix |Y|. +C |F| +C +C REFERENCES +C +C [1] Golub, G.H. and Van Loan, C.F. +C An Analysis of the Total Least-Squares Problem. +C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. +C +C [2] Staar, J., Vandewalle, J. and Wemans, M. +C Realization of Truncated Impulse Response Sequences with +C Prescribed Uncertainty. +C Proc. 8th IFAC World Congress, Kyoto, I, pp. 7-12, 1981. +C +C [3] Van Huffel, S. +C Analysis of the Total Least Squares Problem and its Use in +C Parameter Estimation. +C Doctoral dissertation, Dept. of Electr. Eng., Katholieke +C Universiteit Leuven, Belgium, June 1987. +C +C [4] Van Huffel, S. and Vandewalle, J. +C Analysis and Solution of the Nongeneric Total Least Squares +C Problem. +C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. +C +C [5] Van Huffel, S. and Vandewalle, J. +C The Total Least Squares Problem: Computational Aspects and +C Analysis. +C Series "Frontiers in Applied Mathematics", Vol. 9, +C SIAM, Philadelphia, 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm consists in (backward) stable steps. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB02AD by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C June 24, 1997, Feb. 27, 2000, Oct. 19, 2003, Feb. 21, 2004. +C +C KEYWORDS +C +C Least-squares approximation, singular subspace, singular value +C decomposition, singular values, total least-squares. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION C(LDC,*), DWORK(*), S(*), X(LDX,*) +C .. Local Scalars .. + LOGICAL CRANK, CTOL, LJOBN, LJOBR, LJOBT + INTEGER ITAU, J, JWORK, LDW, K, MINMNL, N1, NL, P, R1, + $ WRKOPT + DOUBLE PRECISION FNORM, RCOND, SMAX, TOLTMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL DLAMCH, DLANGE, DLANTR, LSAME +C .. External Subroutines .. + EXTERNAL DGERQF, DGESVD, DLACPY, DLASET, DORMRQ, DSWAP, + $ DTRCON, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + NL = N + L + K = MAX( M, NL ) + P = MIN( M, N ) + MINMNL = MIN( M, NL ) + LDW = MAX( 3*MINMNL + K, 5*MINMNL ) + LJOBR = LSAME( JOB, 'R' ) + LJOBT = LSAME( JOB, 'T' ) + LJOBN = LSAME( JOB, 'N' ) +C +C Determine whether RANK or/and TOL is/are to be computed. +C + CRANK = .NOT.LJOBT .AND. .NOT.LJOBN + CTOL = .NOT.LJOBR .AND. .NOT.LJOBN +C +C Test the input scalar arguments. +C + IF( CTOL .AND. CRANK .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( .NOT.CRANK .AND. RANK.GT.P ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( CTOL .AND. TOL.LT.ZERO ) THEN + INFO = -11 + ELSE IF( ( M.GE.NL .AND. LDWORK.LT.MAX( 2, LDW ) ).OR. + $ ( M.LT.NL .AND. LDWORK.LT.MAX( 2, M*NL + LDW, 3*L ) ) ) + $ THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB02MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( CRANK ) + $ RANK = P + IF ( MIN( M, NL ).EQ.0 ) THEN + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) + CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) + END IF + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C +C Subroutine MB02MD solves a set of linear equations by a Total +C Least Squares Approximation. +C +C Step 1: Compute part of the singular value decomposition (SVD) +C USV' of C = [A |B ], namely compute S and V'. +C M,N M,L +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( M.GE.NL ) THEN +C +C M >= N + L: Overwrite V' on C. +C Workspace: need max(3*min(M,N+L) + max(M,N+L), 5*min(M,N+L)). +C + JWORK = 1 + CALL DGESVD( 'No left vectors', 'Overwritten on C', M, NL, C, + $ LDC, S, DWORK, 1, DWORK, 1, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + ELSE +C +C M < N + L: Save C in the workspace and compute V' in C. +C Note that the previous DGESVD call cannot be used in this case. +C Workspace: need M*(N+L) + max(3*min(M,N+L) + max(M,N+L), +C 5*min(M,N+L)). +C + CALL DLACPY( 'Full', M, NL, C, LDC, DWORK, M ) + JWORK = M*NL + 1 + CALL DGESVD( 'No left vectors', 'All right vectors', M, NL, + $ DWORK, M, S, DWORK, 1, C, LDC, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + END IF +C + IF ( INFO.GT.0 ) THEN +C +C Save the unconverged non-diagonal elements of the bidiagonal +C matrix and exit. +C + DO 10 J = 1, MINMNL - 1 + DWORK(J) = DWORK(JWORK+J) + 10 CONTINUE +C + RETURN + END IF + WRKOPT = MAX( 2, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Transpose V' in-situ (in C). +C + DO 20 J = 2, NL + CALL DSWAP( J-1, C(J,1), LDC, C(1,J), 1 ) + 20 CONTINUE +C +C Step 2: Compute the rank of the approximation [A+DA|B+DB]. +C + IF ( CTOL ) THEN + TOLTMP = SQRT( TWO*DBLE( K ) )*TOL + SMAX = TOLTMP + ELSE + TOLTMP = TOL + IF ( TOLTMP.LE.ZERO ) TOLTMP = DLAMCH( 'Precision' ) + SMAX = MAX( TOLTMP*S(1), DLAMCH( 'Safe minimum' ) ) + END IF +C + IF ( CRANK ) THEN +C WHILE ( RANK .GT. 0 ) .AND. ( S(RANK) .LE. SMAX ) DO + 40 IF ( RANK.GT.0 ) THEN + IF ( S(RANK).LE.SMAX ) THEN + RANK = RANK - 1 + GO TO 40 + END IF + END IF +C END WHILE 40 + END IF +C + IF ( L.EQ.0 ) THEN + DWORK(1) = WRKOPT + DWORK(2) = ONE + RETURN + END IF +C + N1 = N + 1 + ITAU = 1 + JWORK = ITAU + L +C +C Step 3: Compute the orthogonal matrix Q and matrices F and Y +C such that F is nonsingular. +C +C REPEAT +C +C Adjust the rank if S(RANK) has multiplicity greater than 1. +C + 60 CONTINUE + R1 = RANK + 1 + IF ( RANK.LT.MINMNL ) THEN +C WHILE RANK.GT.0 .AND. S(RANK)**2 - S(R1)**2.LE.TOL**2 DO + 80 IF ( RANK.GT.0 ) THEN + IF ( ONE - ( S(R1)/S(RANK) )**2.LE.( TOLTMP/S(RANK) )**2 + $ ) THEN + RANK = RANK - 1 + IWARN = 1 + GO TO 80 + END IF + END IF +C END WHILE 80 + END IF +C + IF ( RANK.EQ.0 ) THEN +C +C Return zero solution. +C + CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) + DWORK(1) = WRKOPT + DWORK(2) = ONE + RETURN + END IF +C +C Compute the orthogonal matrix Q (in factorized form) and the +C matrices F and Y using RQ factorization. It is assumed that, +C generically, the last L rows of V2 matrix have full rank. +C The code could not be the most efficient one when RANK has been +C lowered, because the already created zero pattern of the last +C L rows of V2 matrix is not exploited. +C Workspace: need 2*L; prefer L + L*NB. +C + R1 = RANK + 1 + CALL DGERQF( L, NL-RANK, C(N1,R1), LDC, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need N+L; prefer L + N*NB. +C + CALL DORMRQ( 'Right', 'Transpose', N, NL-RANK, L, C(N1,R1), + $ LDC, DWORK(ITAU), C(1,R1), LDC, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + CALL DLASET( 'Full', L, N-RANK, ZERO, ZERO, C(N1,R1), LDC ) + IF ( L.GT.1 ) + $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, C(N1+1,N1), + $ LDC ) +C +C Estimate the reciprocal condition number of the matrix F, +C and lower the rank if F can be considered as singular. +C Workspace: need 3*L. +C + CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, C(N1,N1), LDC, + $ RCOND, DWORK, IWORK, INFO ) + WRKOPT = MAX( WRKOPT, 3*L ) +C + FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, C(N1,N1), + $ LDC, DWORK ) + IF ( RCOND.LE.TOLTMP*FNORM ) THEN + RANK = RANK - 1 + IWARN = 2 + GO TO 60 + ELSE IF ( FNORM.LE.TOLTMP*DLANGE( '1-norm', N, L, C(1,N1), LDC, + $ DWORK ) ) THEN + RANK = RANK - L + IWARN = 2 + GO TO 60 + END IF +C UNTIL ( F nonsingular, i.e., RCOND.GT.TOL*FNORM or +C FNORM.GT.TOL*norm(Y) ) +C +C Step 4: Solve X F = -Y by forward elimination, +C (F is upper triangular). +C + CALL DLACPY( 'Full', N, L, C(1,N1), LDC, X, LDX ) + CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, + $ -ONE, C(N1,N1), LDC, X, LDX ) +C +C Set the optimal workspace and reciprocal condition number of F. +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of MB02MD *** + END diff --git a/mex/sources/libslicot/MB02ND.f b/mex/sources/libslicot/MB02ND.f new file mode 100644 index 000000000..047296025 --- /dev/null +++ b/mex/sources/libslicot/MB02ND.f @@ -0,0 +1,889 @@ + SUBROUTINE MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL, + $ TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the Total Least Squares (TLS) problem using a Partial +C Singular Value Decomposition (PSVD) approach. +C The TLS problem assumes an overdetermined set of linear equations +C AX = B, where both the data matrix A as well as the observation +C matrix B are inaccurate. The routine also solves determined and +C underdetermined sets of equations by computing the minimum norm +C solution. +C It is assumed that all preprocessing measures (scaling, coordinate +C transformations, whitening, ... ) of the data have been performed +C in advance. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in the data matrix A and the +C observation matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns in the data matrix A. N >= 0. +C +C L (input) INTEGER +C The number of columns in the observation matrix B. +C L >= 0. +C +C RANK (input/output) INTEGER +C On entry, if RANK < 0, then the rank of the TLS +C approximation [A+DA|B+DB] (r say) is computed by the +C routine. +C Otherwise, RANK must specify the value of r. +C RANK <= min(M,N). +C On exit, if RANK < 0 on entry and INFO = 0, then RANK +C contains the computed rank of the TLS approximation +C [A+DA|B+DB]. +C Otherwise, the user-supplied value of RANK may be +C changed by the routine on exit if the RANK-th and the +C (RANK+1)-th singular values of C = [A|B] are considered +C to be equal, or if the upper triangular matrix F (as +C defined in METHOD) is (numerically) singular. +C +C THETA (input/output) DOUBLE PRECISION +C On entry, if RANK < 0, then the rank of the TLS +C approximation [A+DA|B+DB] is computed using THETA as +C (min(M,N+L) - d), where d is the number of singular +C values of [A|B] <= THETA. THETA >= 0.0. +C Otherwise, THETA is an initial estimate (t say) for +C computing a lower bound on the RANK largest singular +C values of [A|B]. If THETA < 0.0 on entry however, then +C t is computed by the routine. +C On exit, if RANK >= 0 on entry, then THETA contains the +C computed bound such that precisely RANK singular values +C of C = [A|B] are greater than THETA + TOL. +C Otherwise, THETA is unchanged. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N+L) +C On entry, the leading M-by-(N+L) part of this array must +C contain the matrices A and B. Specifically, the first N +C columns must contain the data matrix A and the last L +C columns the observation matrix B (right-hand sides). +C On exit, if INFO = 0, the first N+L components of the +C columns of this array whose index i corresponds with +C INUL(i) = .TRUE., are the possibly transformed (N+L-RANK) +C base vectors of the right singular subspace corresponding +C to the singular values of C = [A|B] which are less than or +C equal to THETA. Specifically, if L = 0, or if RANK = 0 and +C IWARN <> 2, these vectors are indeed the base vectors +C above. Otherwise, these vectors form the matrix V2, +C transformed as described in Step 4 of the PTLS algorithm +C (see METHOD). The TLS solution is computed from these +C vectors. The other columns of array C contain no useful +C information. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= max(1,M,N+L). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,L) +C If INFO = 0, the leading N-by-L part of this array +C contains the solution X to the TLS problem specified by +C A and B. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= max(1,N). +C +C Q (output) DOUBLE PRECISION array, dimension +C (max(1,2*min(M,N+L)-1)) +C This array contains the partially diagonalized bidiagonal +C matrix J computed from C, at the moment that the desired +C singular subspace has been found. Specifically, the +C leading p = min(M,N+L) entries of Q contain the diagonal +C elements q(1),q(2),...,q(p) and the entries Q(p+1),Q(p+2), +C ...,Q(2*p-1) contain the superdiagonal elements e(1),e(2), +C ...,e(p-1) of J. +C +C INUL (output) LOGICAL array, dimension (N+L) +C The indices of the elements of this array with value +C .TRUE. indicate the columns in C containing the base +C vectors of the right singular subspace of C from which +C the TLS solution has been computed. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C This parameter defines the multiplicity of singular values +C by considering all singular values within an interval of +C length TOL as coinciding. TOL is used in checking how many +C singular values are less than or equal to THETA. Also in +C computing an appropriate upper bound THETA by a bisection +C method, TOL is used as a stopping criterion defining the +C minimum (absolute) subinterval width. TOL is also taken +C as an absolute tolerance for negligible elements in the +C QR/QL iterations. If the user sets TOL to be less than or +C equal to 0, then the tolerance is taken as specified in +C SLICOT Library routine MB04YD document. +C +C RELTOL DOUBLE PRECISION +C This parameter specifies the minimum relative width of an +C interval. When an interval is narrower than TOL, or than +C RELTOL times the larger (in magnitude) endpoint, then it +C is considered to be sufficiently small and bisection has +C converged. If the user sets RELTOL to be less than +C BASE * EPS, where BASE is machine radix and EPS is machine +C precision (see LAPACK Library routine DLAMCH), then the +C tolerance is taken as BASE * EPS. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+2*L) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2) returns the reciprocal of the +C condition number of the matrix F. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = max(2, max(M,N+L) + 2*min(M,N+L), +C min(M,N+L) + LW + max(6*(N+L)-5, +C L*L+max(N+L,3*L)), +C where +C LW = (N+L)*(N+L-1)/2, if M >= N+L, +C LW = M*(N+L-(M-1)/2), if M < N+L. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (N+L) +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warnings; +C = 1: if the rank of matrix C has been lowered because a +C singular value of multiplicity greater than 1 was +C found; +C = 2: if the rank of matrix C has been lowered because the +C upper triangular matrix F is (numerically) singular. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the maximum number of QR/QL iteration steps +C (30*MIN(M,N)) has been exceeded; +C = 2: if the computed rank of the TLS approximation +C [A+DA|B+DB] exceeds MIN(M,N). Try increasing the +C value of THETA or set the value of RANK to min(M,N). +C +C METHOD +C +C The method used is the Partial Total Least Squares (PTLS) approach +C proposed by Van Huffel and Vandewalle [5]. +C +C Let C = [A|B] denote the matrix formed by adjoining the columns of +C B to the columns of A on the right. +C +C Total Least Squares (TLS) definition: +C ------------------------------------- +C +C Given matrices A and B, find a matrix X satisfying +C +C (A + DA) X = B + DB, +C +C where A and DA are M-by-N matrices, B and DB are M-by-L matrices +C and X is an N-by-L matrix. +C The solution X must be such that the Frobenius norm of [DA|DB] +C is a minimum and each column of B + DB is in the range of +C A + DA. Whenever the solution is not unique, the routine singles +C out the minimum norm solution X. +C +C Let V denote the right singular subspace of C. Since the TLS +C solution can be computed from any orthogonal basis of the subspace +C of V corresponding to the smallest singular values of C, the +C Partial Singular Value Decomposition (PSVD) can be used instead of +C the classical SVD. The dimension of this subspace of V may be +C determined by the rank of C or by an upper bound for those +C smallest singular values. +C +C The PTLS algorithm proceeds as follows (see [2 - 5]): +C +C Step 1: Bidiagonalization phase +C ----------------------- +C (a) If M is large enough than N + L, transform C into upper +C triangular form R by Householder transformations. +C (b) Transform C (or R) into upper bidiagonal form +C (p = min(M,N+L)): +C +C |q(1) e(1) 0 ... 0 | +C (0) | 0 q(2) e(2) . | +C J = | . . | +C | . e(p-1)| +C | 0 ... q(p) | +C +C if M >= N + L, or lower bidiagonal form: +C +C |q(1) 0 0 ... 0 0 | +C (0) |e(1) q(2) 0 . . | +C J = | . . . | +C | . q(p) . | +C | 0 ... e(p-1) q(p)| +C +C if M < N + L, using Householder transformations. +C In the second case, transform the matrix to the upper +C bidiagonal form by applying Givens rotations. +C (c) Initialize the right singular base matrix with the identity +C matrix. +C +C Step 2: Partial diagonalization phase +C ----------------------------- +C If the upper bound THETA is not given, then compute THETA such +C that precisely p - RANK singular values (p=min(M,N+L)) of the +C bidiagonal matrix are less than or equal to THETA, using a +C bisection method [5]. Diagonalize the given bidiagonal matrix J +C partially, using either QL iterations (if the upper left diagonal +C element of the considered bidiagonal submatrix is smaller than the +C lower right diagonal element) or QR iterations, such that J is +C split into unreduced bidiagonal submatrices whose singular values +C are either all larger than THETA or are all less than or equal +C to THETA. Accumulate the Givens rotations in V. +C +C Step 3: Back transformation phase +C ------------------------- +C Apply the Householder transformations of Step 1(b) onto the base +C vectors of V associated with the bidiagonal submatrices with all +C singular values less than or equal to THETA. +C +C Step 4: Computation of F and Y +C ---------------------- +C Let V2 be the matrix of the columns of V corresponding to the +C (N + L - RANK) smallest singular values of C. +C Compute with Householder transformations the matrices F and Y +C such that: +C +C |VH Y| +C V2 x Q = | | +C |0 F| +C +C where Q is an orthogonal matrix, VH is an N-by-(N-RANK) matrix, +C Y is an N-by-L matrix and F is an L-by-L upper triangular matrix. +C If F is singular, then reduce the value of RANK by one and repeat +C Steps 2, 3 and 4. +C +C Step 5: Computation of the TLS solution +C ------------------------------- +C If F is non-singular then the solution X is obtained by solving +C the following equations by forward elimination: +C +C X F = -Y. +C +C Notes: +C If RANK is lowered in Step 4, some additional base vectors must +C be computed in Step 2. The additional computations are kept to +C a minimum. +C If RANK is lowered in Step 4 but the multiplicity of the RANK-th +C singular value is larger than 1, then the value of RANK is further +C lowered with its multiplicity defined by the parameter TOL. This +C is done at the beginning of Step 2 by calling SLICOT Library +C routine MB03MD (from MB04YD), which estimates THETA using a +C bisection method. If F in Step 4 is singular, then the computed +C solution is infinite and hence does not satisfy the second TLS +C criterion (see TLS definition). For these cases, Golub and +C Van Loan [1] claim that the TLS problem has no solution. The +C properties of these so-called nongeneric problems are described +C in [6] and the TLS computations are generalized in order to solve +C them. As proven in [6], the proposed generalization satisfies the +C TLS criteria for any number L of observation vectors in B provided +C that, in addition, the solution | X| is constrained to be +C |-I| +C orthogonal to all vectors of the form |w| which belong to the +C |0| +C space generated by the columns of the submatrix |Y|. +C |F| +C +C REFERENCES +C +C [1] Golub, G.H. and Van Loan, C.F. +C An Analysis of the Total Least-Squares Problem. +C SIAM J. Numer. Anal., 17, pp. 883-893, 1980. +C +C [2] Van Huffel, S., Vandewalle, J. and Haegemans, A. +C An Efficient and Reliable Algorithm for Computing the +C Singular Subspace of a Matrix Associated with its Smallest +C Singular Values. +C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. +C +C [3] Van Huffel, S. +C Analysis of the Total Least Squares Problem and its Use in +C Parameter Estimation. +C Doctoral dissertation, Dept. of Electr. Eng., Katholieke +C Universiteit Leuven, Belgium, June 1987. +C +C [4] Chan, T.F. +C An Improved Algorithm for Computing the Singular Value +C Decomposition. +C ACM TOMS, 8, pp. 72-83, 1982. +C +C [5] Van Huffel, S. and Vandewalle, J. +C The Partial Total Least Squares Algorithm. +C J. Comput. Appl. Math., 21, pp. 333-341, 1988. +C +C [6] Van Huffel, S. and Vandewalle, J. +C Analysis and Solution of the Nongeneric Total Least Squares +C Problem. +C SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988. +C +C NUMERICAL ASPECTS +C +C The computational efficiency of the PTLS algorithm compared with +C the classical TLS algorithm (see [2 - 5]) is obtained by making +C use of PSVD (see [1]) instead of performing the entire SVD. +C Depending on the gap between the RANK-th and the (RANK+1)-th +C singular values of C, the number (N + L - RANK) of base vectors to +C be computed with respect to the column dimension (N + L) of C and +C the desired accuracy RELTOL, the algorithm used by this routine is +C approximately twice as fast as the classical TLS algorithm at the +C expense of extra storage requirements, namely: +C (N + L) x (N + L - 1)/2 if M >= N + L or +C M x (N + L - (M - 1)/2) if M < N + L. +C This is because the Householder transformations performed on the +C rows of C in the bidiagonalization phase (see Step 1) must be kept +C until the end (Step 5). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB02BD by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C June 30, 1997, Oct. 19, 2003, Feb. 15, 2004. +C +C KEYWORDS +C +C Least-squares approximation, singular subspace, singular value +C decomposition, singular values, total least-squares. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK + DOUBLE PRECISION RELTOL, THETA, TOL +C .. Array Arguments .. + LOGICAL BWORK(*), INUL(*) + INTEGER IWORK(*) + DOUBLE PRECISION C(LDC,*), DWORK(*), Q(*), X(LDX,*) +C .. Local Scalars .. + LOGICAL LFIRST, SUFWRK + INTEGER I, I1, IFAIL, IHOUSH, IJ, IOFF, ITAUP, ITAUQ, + $ IWARM, J, J1, JF, JV, JWORK, K, KF, KJ, LDF, LW, + $ MC, MJ, MNL, N1, NJ, NL, P, WRKOPT + DOUBLE PRECISION CS, EPS, FIRST, FNORM, HH, INPROD, RCOND, SN, + $ TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL DLAMCH, DLANGE, DLANTR, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBRD, DGEQRF, DGERQF, DLARF, DLARFG, + $ DLARTG, DLASET, DORMBR, DORMRQ, DTRCON, DTRSM, + $ MB04YD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + NL = N + L + K = MAX( M, NL ) + P = MIN( M, NL ) + IF ( M.GE.NL ) THEN + LW = ( NL*( NL - 1 ) )/2 + ELSE + LW = M*NL - ( M*( M - 1 ) )/2 + END IF + JV = P + LW + MAX( 6*NL - 5, L*L + MAX( NL, 3*L ) ) +C +C Test the input scalar arguments. +C + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 ) THEN + INFO = -3 + ELSE IF( RANK.GT.MIN( M, N ) ) THEN + INFO = -4 + ELSE IF( ( RANK.LT.0 ) .AND. ( THETA.LT.ZERO ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDWORK.LT.MAX( 2, K + 2*P, JV ) ) THEN + INFO = -16 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB02ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, NL ).EQ.0 ) THEN + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) + CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX ) +C + DO 10 I = 1, NL + INUL(I) = .TRUE. + 10 CONTINUE +C + END IF + IF ( RANK.GE.0 ) + $ THETA = ZERO + RANK = 0 + DWORK(1) = TWO + DWORK(2) = ONE + RETURN + END IF +C + WRKOPT = 2 + N1 = N + 1 +C + EPS = DLAMCH( 'Precision' ) + LFIRST = .TRUE. +C +C Initializations. +C + DO 20 I = 1, P + INUL(I) = .FALSE. + BWORK(I) = .FALSE. + 20 CONTINUE +C + DO 40 I = P + 1, NL + INUL(I) = .TRUE. + BWORK(I) = .FALSE. + 40 CONTINUE +C +C Subroutine MB02ND solves a set of linear equations by a Total +C Least Squares Approximation, based on the Partial SVD. +C +C Step 1: Bidiagonalization phase +C ----------------------- +C 1.a): If M is large enough than N+L, transform C into upper +C triangular form R by Householder transformations. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( M.GE.MAX( NL, + $ ILAENV( 6, 'DGESVD', 'N' // 'N', M, NL, 0, 0 ) ) ) + $ THEN +C +C Workspace: need 2*(N+L), +C prefer N+L + (N+L)*NB. +C + ITAUQ = 1 + JWORK = ITAUQ + NL + CALL DGEQRF( M, NL, C, LDC, DWORK(ITAUQ), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + IF ( NL.GT.1 ) + $ CALL DLASET( 'Lower', NL-1, NL-1, ZERO, ZERO, C(2,1), LDC ) + MNL = NL + ELSE + MNL = M + END IF +C +C 1.b): Transform C (or R) into bidiagonal form Q using Householder +C transformations. +C Workspace: need 2*min(M,N+L) + max(M,N+L), +C prefer 2*min(M,N+L) + (M+N+L)*NB. +C + ITAUP = 1 + ITAUQ = ITAUP + P + JWORK = ITAUQ + P + CALL DGEBRD( MNL, NL, C, LDC, Q, Q(P+1), DWORK(ITAUQ), + $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C If the matrix is lower bidiagonal, rotate to be upper bidiagonal +C by applying Givens rotations on the left. +C + IF ( M.LT.NL ) THEN + IOFF = 0 +C + DO 60 I = 1, P - 1 + CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) + Q(I) = TEMP + Q(P+I) = SN*Q(I+1) + Q(I+1) = CS*Q(I+1) + 60 CONTINUE +C + ELSE + IOFF = 1 + END IF +C +C Store the Householder transformations performed onto the rows of C +C in the extra storage locations DWORK(IHOUSH). +C Workspace: need LDW = min(M,N+L) + (N+L)*(N+L-1)/2, if M >= N+L, +C LDW = min(M,N+L) + M*(N+L-(M-1)/2), if M < N+L; +C prefer LDW = min(M,N+L) + (N+L)**2, if M >= N+L, +C LDW = min(M,N+L) + M*(N+L), if M < N+L. +C + IHOUSH = ITAUQ + MC = NL - IOFF + KF = IHOUSH + P*NL + SUFWRK = LDWORK.GE.( KF + MAX( 6*(N+L)-5, + $ NL**2 + MAX( NL, 3*L ) - 1 ) ) + IF ( SUFWRK ) THEN +C +C Enough workspace for a fast algorithm. +C + CALL DLACPY( 'Upper', P, NL, C, LDC, DWORK(IHOUSH), P ) + KJ = KF + WRKOPT = MAX( WRKOPT, KF - 1 ) + ELSE +C +C Not enough workspace for a fast algorithm. +C + KJ = IHOUSH +C + DO 80 NJ = 1, MIN( P, MC ) + J = MC - NJ + 1 + CALL DCOPY( J, C(NJ,NJ+IOFF), LDC, DWORK(KJ), 1 ) + KJ = KJ + J + 80 CONTINUE +C + END IF +C +C 1.c): Initialize the right singular base matrix V with the +C identity matrix (V overwrites C). +C + CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC ) + JV = KJ + IWARM = 0 +C +C REPEAT +C +C Compute the Householder matrix Q and matrices F and Y such that +C F is nonsingular. +C +C Step 2: Partial diagonalization phase. +C ----------------------------- +C Diagonalize the bidiagonal Q partially until convergence to +C the desired right singular subspace. +C Workspace: LDW + 6*(N+L)-5. +C + 100 CONTINUE + JWORK = JV + CALL MB04YD( 'No U', 'Update V', P, NL, RANK, THETA, Q, Q(P+1), + $ DUMMY, 1, C, LDC, INUL, TOL, RELTOL, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARN, INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 6*NL - 6 ) +C + IWARN = MAX( IWARN, IWARM ) + IF ( INFO.GT.0 ) + $ RETURN +C +C Set pointers to the selected base vectors in the right singular +C matrix of C. +C + K = 0 +C + DO 120 I = 1, NL + IF ( INUL(I) ) THEN + K = K + 1 + IWORK(K) = I + END IF + 120 CONTINUE +C + IF ( K.LT.L ) THEN +C +C Rank of the TLS approximation is larger than min(M,N). +C + INFO = 2 + RETURN + END IF +C +C Step 3: Back transformation phase. +C ------------------------- +C Apply in backward order the Householder transformations (stored +C in DWORK(IHOUSH)) performed onto the rows of C during the +C bidiagonalization phase, to the selected base vectors (specified +C by INUL(I) = .TRUE.). Already transformed vectors are those for +C which BWORK(I) = .TRUE.. +C + KF = K + IF ( SUFWRK.AND.LFIRST ) THEN +C +C Enough workspace for a fast algorithm and first pass. +C + IJ = JV +C + DO 140 J = 1, K + CALL DCOPY (NL, C(1,IWORK(J)), 1, DWORK(IJ), 1 ) + IJ = IJ + NL + 140 CONTINUE +C +C Workspace: need LDW + (N+L)*K + K, +C prefer LDW + (N+L)*K + K*NB. +C + IJ = JV + JWORK = IJ + NL*K + CALL DORMBR( 'P vectors', 'Left', 'No transpose', NL, K, + $ MNL, DWORK(IHOUSH), P, DWORK(ITAUP), DWORK(IJ), + $ NL, DWORK(JWORK), LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + DO 160 I = 1, NL + IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) + $ BWORK(I) = .TRUE. + 160 CONTINUE +C + ELSE +C +C Not enough workspace for a fast algorithm or subsequent passes. +C + DO 180 I = 1, NL + IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) THEN + KJ = JV +C + DO 170 NJ = MIN( P, MC ), 1, -1 + J = MC - NJ + 1 + KJ = KJ - J + FIRST = DWORK(KJ) + DWORK(KJ) = ONE + CALL DLARF( 'Left', J, 1, DWORK(KJ), 1, + $ DWORK(ITAUP+NJ-1), C(NJ+IOFF,I), LDC, + $ DWORK(JWORK) ) + DWORK(KJ) = FIRST + 170 CONTINUE +C + BWORK(I) = .TRUE. + END IF + 180 CONTINUE + END IF +C + IF ( RANK.LE.0 ) + $ RANK = 0 + IF ( MIN( RANK, L ).EQ.0 ) THEN + IF ( SUFWRK.AND.LFIRST ) + $ CALL DLACPY( 'Full', NL, K, DWORK(JV), NL, C, LDC ) + DWORK(1) = WRKOPT + DWORK(2) = ONE + RETURN + END IF +C +C Step 4: Compute matrices F and Y +C ------------------------ +C using Householder transformation Q. +C +C Compute the orthogonal matrix Q (in factorized form) and the +C matrices F and Y using RQ factorization. It is assumed that, +C generically, the last L rows of V2 matrix have full rank. +C The code could not be the most efficient when RANK has been +C lowered, because the already created zero pattern of the last +C L rows of V2 matrix is not exploited. +C + IF ( SUFWRK.AND.LFIRST ) THEN +C +C Enough workspace for a fast algorithm and first pass. +C Workspace: need LDW1 + 2*L, +C prefer LDW1 + L + L*NB, where +C LDW1 = LDW + (N+L)*K; +C + ITAUQ = JWORK + JWORK = ITAUQ + L + CALL DGERQF( L, K, DWORK(JV+N), NL, DWORK(ITAUQ), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need LDW1 + N+L, +C prefer LDW1 + L + N*NB. +C + CALL DORMRQ( 'Right', 'Transpose', N, K, L, DWORK(JV+N), NL, + $ DWORK(ITAUQ), DWORK(JV), NL, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + JF = JV + NL*(K-L) + N + LDF = NL + JWORK = JF + LDF*L - N + CALL DLASET( 'Full', L, K-L, ZERO, ZERO, DWORK(JV+N), LDF ) + IF ( L.GT.1 ) + $ CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, DWORK(JF+1), + $ LDF ) + IJ = JV +C + DO 200 J = 1, K + CALL DCOPY( NL, DWORK(IJ), 1, C(1,IWORK(J)), 1 ) + IJ = IJ + NL + 200 CONTINUE +C + ELSE +C +C Not enough workspace for a fast algorithm or subsequent passes. +C Workspace: LDW2 + N+L, where LDW2 = LDW + L*L. +C + I = NL + JF = JV + LDF = L + JWORK = JF + LDF*L + WRKOPT = MAX( WRKOPT, JWORK+NL-1 ) +C +C WHILE ( ( K >= 1 ) .AND. ( I > N ) ) DO + 220 CONTINUE + IF ( ( K.GE.1 ) .AND. ( I.GT.N ) ) THEN +C + DO 240 J = 1, K + DWORK(JWORK+J-1) = C(I,IWORK(J)) + 240 CONTINUE +C +C Compute Householder transformation. +C + CALL DLARFG( K, DWORK(JWORK+K-1), DWORK(JWORK), 1, TEMP ) + C(I,IWORK(K)) = DWORK(JWORK+K-1) + IF ( TEMP.NE.ZERO ) THEN +C +C Apply Householder transformation onto the selected base +C vectors. +C + DO 300 I1 = 1, I - 1 + INPROD = C(I1,IWORK(K)) +C + DO 260 J = 1, K - 1 + INPROD = INPROD + DWORK(JWORK+J-1)*C(I1,IWORK(J)) + 260 CONTINUE +C + HH = INPROD*TEMP + C(I1,IWORK(K)) = C(I1,IWORK(K)) - HH +C + DO 280 J = 1, K - 1 + J1 = IWORK(J) + C(I1,J1) = C(I1,J1) - DWORK(JWORK+J-1)*HH + C(I,J1) = ZERO + 280 CONTINUE +C + 300 CONTINUE +C + END IF + CALL DCOPY( I-N, C(N1,IWORK(K)), 1, DWORK(JF+(I-N-1)*L), 1 ) + K = K - 1 + I = I - 1 + GO TO 220 + END IF +C END WHILE 220 + END IF +C +C Estimate the reciprocal condition number of the matrix F. +C If F singular, lower the rank of the TLS approximation. +C Workspace: LDW1 + 3*L or +C LDW2 + 3*L. +C + CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, DWORK(JF), LDF, + $ RCOND, DWORK(JWORK), IWORK(KF+1), INFO ) + WRKOPT = MAX( WRKOPT, JWORK + 3*L - 1 ) +C + DO 320 J = 1, L + CALL DCOPY( N, C(1,IWORK(KF-L+J)), 1, X(1,J), 1 ) + 320 CONTINUE +C + FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, DWORK(JF), + $ LDF, DWORK(JWORK) ) + IF ( RCOND.LE.EPS*FNORM ) THEN + RANK = RANK - 1 + GO TO 340 + END IF + IF ( FNORM.LE.EPS*DLANGE( '1-norm', N, L, X, LDX, + $ DWORK(JWORK) ) ) THEN + RANK = RANK - L + GO TO 340 + ELSE + GO TO 400 + END IF +C + 340 CONTINUE + IWARM = 2 + THETA = -ONE + IF ( SUFWRK.AND.LFIRST ) THEN +C +C Rearrange the stored Householder transformations for +C subsequent passes, taking care to avoid overwriting. +C + IF ( P.LT.NL ) THEN + KJ = IHOUSH + NL*(NL - 1) + MJ = IHOUSH + P*(NL - 1) +C + DO 360 NJ = 1, NL + DO 350 J = P - 1, 0, -1 + DWORK(KJ+J) = DWORK(MJ+J) + 350 CONTINUE + KJ = KJ - NL + MJ = MJ - P + 360 CONTINUE +C + END IF + KJ = IHOUSH + MJ = IHOUSH + NL*IOFF +C + DO 380 NJ = 1, MIN( P, MC ) + DO 370 J = 0, MC - NJ + DWORK(KJ) = DWORK(MJ+J*P) + KJ = KJ + 1 + 370 CONTINUE + MJ = MJ + NL + 1 + 380 CONTINUE +C + JV = KJ + LFIRST = .FALSE. + END IF + GO TO 100 +C UNTIL ( F nonsingular, i.e., RCOND.GT.EPS*FNORM or +C FNORM.GT.EPS*norm(Y) ) + 400 CONTINUE +C +C Step 5: Compute TLS solution. +C -------------------- +C Solve X F = -Y by forward elimination (F is upper triangular). +C + CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L, + $ -ONE, DWORK(JF), LDF, X, LDX ) +C +C Set the optimal workspace and reciprocal condition number of F. +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of MB02ND *** + END diff --git a/mex/sources/libslicot/MB02NY.f b/mex/sources/libslicot/MB02NY.f new file mode 100644 index 000000000..acf0bce5a --- /dev/null +++ b/mex/sources/libslicot/MB02NY.f @@ -0,0 +1,261 @@ + SUBROUTINE MB02NY( UPDATU, UPDATV, M, N, I, K, Q, E, U, LDU, V, + $ LDV, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To separate a zero singular value of a bidiagonal submatrix of +C order k, k <= p, of the bidiagonal matrix +C +C |Q(1) E(1) 0 ... 0 | +C | 0 Q(2) E(2) . | +C J = | . . | +C | . E(p-1)| +C | 0 ... ... ... Q(p) | +C +C with p = MIN(M,N), by annihilating one or two superdiagonal +C elements E(i-1) (if i > 1) and/or E(i) (if i < k). +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATU LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix U the left-hand Givens rotations S, as follows: +C = .FALSE.: Do not form U; +C = .TRUE. : The given matrix U is updated (postmultiplied) +C by the left-hand Givens rotations S. +C +C UPDATV LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix V the right-hand Givens rotations T, as follows: +C = .FALSE.: Do not form V; +C = .TRUE. : The given matrix V is updated (postmultiplied) +C by the right-hand Givens rotations T. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix U. M >= 0. +C +C N (input) INTEGER +C The number of rows of the matrix V. N >= 0. +C +C I (input) INTEGER +C The index of the negligible diagonal entry Q(I) of the +C bidiagonal matrix J, I <= p. +C +C K (input) INTEGER +C The index of the last diagonal entry of the considered +C bidiagonal submatrix of J, i.e., E(K-1) is considered +C negligible, K <= p. +C +C Q (input/output) DOUBLE PRECISION array, dimension (p) +C where p = MIN(M,N). +C On entry, Q must contain the diagonal entries of the +C bidiagonal matrix J. +C On exit, Q contains the diagonal entries of the +C transformed bidiagonal matrix S' J T. +C +C E (input/output) DOUBLE PRECISION array, dimension (p-1) +C On entry, E must contain the superdiagonal entries of J. +C On exit, E contains the superdiagonal entries of the +C transformed bidiagonal matrix S' J T. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) +C On entry, if UPDATU = .TRUE., U must contain the M-by-p +C left transformation matrix. +C On exit, if UPDATU = .TRUE., the Givens rotations S on the +C left, annihilating E(i) if i < k, have been postmultiplied +C into U. +C U is not referenced if UPDATU = .FALSE.. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= max(1,M) if UPDATU = .TRUE.; +C LDU >= 1 if UPDATU = .FALSE.. +C +C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) +C On entry, if UPDATV = .TRUE., V must contain the N-by-p +C right transformation matrix. +C On exit, if UPDATV = .TRUE., the Givens rotations T on the +C right, annihilating E(i-1) if i > 1, have been +C postmultiplied into V. +C V is not referenced if UPDATV = .FALSE.. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= max(1,N) if UPDATV = .TRUE.; +C LDV >= 1 if UPDATV = .FALSE.. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) +C LDWORK >= 2*MAX(K-I,I-1), if UPDATV = UPDATU = .TRUE.; +C LDWORK >= 2*(K-I), if UPDATU = .TRUE., UPDATV = .FALSE.; +C LDWORK >= 2*(I-1), if UPDATV = .TRUE., UPDATU = .FALSE.; +C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. +C +C METHOD +C +C Let the considered bidiagonal submatrix be +C +C |Q(1) E(1) 0 ... 0 | +C | 0 Q(2) E(2) . | +C | . . | +C | . Q(i-1) E(i-1) . | +C Jk = | . Q(i) E(i) . |. +C | . Q(i+1) . . | +C | . .. . | +C | . E(k-1)| +C | 0 ... ... Q(k) | +C +C A zero singular value of Jk manifests itself by a zero diagonal +C entry Q(i) or in practice, a negligible value of Q(i). +C When a negligible diagonal element Q(i) in Jk is present, the +C bidiagonal submatrix Jk is split by the routine into 2 or 3 +C unreduced bidiagonal submatrices by annihilating E(i) (if i < k) +C using Givens rotations S on the left and by annihilating E(i-1) +C (if i > 1) using Givens rotations T on the right until Jk is +C reduced to the form: +C +C |Q(1) E(1) 0 ... 0 | +C | 0 . ... . | +C | . ... . | +C | . Q(i-1) 0 . | +C S' Jk T = | . 0 0 . |. +C | . Q(i+1) . . | +C | . .. . | +C | . E(k-1)| +C | 0 ... ... Q(k) | +C +C For more details, see [1, pp.11.12-11.14]. +C +C REFERENCES +C +C [1] Dongarra, J.J., Bunch, J.R., Moler C.B. and Stewart, G.W. +C LINPACK User's Guide. +C SIAM, Philadelphia, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB02BZ by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Bidiagonal matrix, orthogonal transformation, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATU, UPDATV + INTEGER I, K, LDU, LDV, M, N +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + INTEGER I1, IROT, L, L1, NROT + DOUBLE PRECISION C, F, G, R, S +C .. External Subroutines .. + EXTERNAL DLARTG, DLASR +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For speed, no tests of the input scalar arguments are done. +C +C Quick return if possible. +C + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C + IF ( I.LE.MIN( M, N ) ) Q(I) = ZERO +C +C Annihilate E(I) (if I < K). +C + IF ( I.LT.K ) THEN + C = ZERO + S = ONE + IROT = 0 + NROT = K - I +C + DO 20 L = I, K-1 + G = E(L) + E(L) = C*G + CALL DLARTG( Q(L+1), S*G, C, S, R ) + Q(L+1) = R + IF ( UPDATU ) THEN + IROT = IROT + 1 + DWORK(IROT) = C + DWORK(IROT+NROT) = S + END IF + 20 CONTINUE +C + IF ( UPDATU ) + $ CALL DLASR( 'Right', 'Top', 'Forward', M, NROT+1, DWORK(1), + $ DWORK(NROT+1), U(1,I), LDU ) + END IF +C +C Annihilate E(I-1) (if I > 1). +C + IF ( I.GT.1 ) THEN + I1 = I - 1 + F = E(I1) + E(I1) = ZERO +C + DO 40 L1 = 1, I1 - 1 + L = I - L1 + CALL DLARTG( Q(L), F, C, S, R ) + Q(L) = R + IF ( UPDATV ) THEN + DWORK(L) = C + DWORK(L+I1) = S + END IF + G = E(L-1) + F = -S*G + E(L-1) = C*G + 40 CONTINUE +C + CALL DLARTG( Q(1), F, C, S, R ) + Q(1) = R + IF ( UPDATV ) THEN + DWORK(1) = C + DWORK(I) = S + CALL DLASR( 'Right', 'Bottom', 'Backward', N, I, DWORK(1), + $ DWORK(I), V(1,1), LDV ) + END IF + END IF +C + RETURN +C *** Last line of MB02NY *** + END diff --git a/mex/sources/libslicot/MB02OD.f b/mex/sources/libslicot/MB02OD.f new file mode 100644 index 000000000..0a6929954 --- /dev/null +++ b/mex/sources/libslicot/MB02OD.f @@ -0,0 +1,267 @@ + SUBROUTINE MB02OD( SIDE, UPLO, TRANS, DIAG, NORM, M, N, ALPHA, A, + $ LDA, B, LDB, RCOND, TOL, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve (if well-conditioned) one of the matrix equations +C +C op( A )*X = alpha*B, or X*op( A ) = alpha*B, +C +C where alpha is a scalar, X and B are m-by-n matrices, A is a unit, +C or non-unit, upper or lower triangular matrix and op( A ) is one +C of +C +C op( A ) = A or op( A ) = A'. +C +C An estimate of the reciprocal of the condition number of the +C triangular matrix A, in either the 1-norm or the infinity-norm, is +C also computed as +C +C RCOND = 1 / ( norm(A) * norm(inv(A)) ). +C +C and the specified matrix equation is solved only if RCOND is +C larger than a given tolerance TOL. In that case, the matrix X is +C overwritten on B. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specifies whether op( A ) appears on the left or right +C of X as follows: +C = 'L': op( A )*X = alpha*B; +C = 'R': X*op( A ) = alpha*B. +C +C UPLO CHARACTER*1 +C Specifies whether the matrix A is an upper or lower +C triangular matrix as follows: +C = 'U': A is an upper triangular matrix; +C = 'L': A is a lower triangular matrix. +C +C TRANS CHARACTER*1 +C Specifies the form of op( A ) to be used in the matrix +C multiplication as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C DIAG CHARACTER*1 +C Specifies whether or not A is unit triangular as follows: +C = 'U': A is assumed to be unit triangular; +C = 'N': A is not assumed to be unit triangular. +C +C NORM CHARACTER*1 +C Specifies whether the 1-norm condition number or the +C infinity-norm condition number is required: +C = '1' or 'O': 1-norm; +C = 'I': Infinity-norm. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of B. M >= 0. +C +C N (input) INTEGER +C The number of columns of B. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then A is not +C referenced and B need not be set before entry. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,k), +C where k is M when SIDE = 'L' and is N when SIDE = 'R'. +C On entry with UPLO = 'U', the leading k-by-k upper +C triangular part of this array must contain the upper +C triangular matrix and the strictly lower triangular part +C of A is not referenced. +C On entry with UPLO = 'L', the leading k-by-k lower +C triangular part of this array must contain the lower +C triangular matrix and the strictly upper triangular part +C of A is not referenced. +C Note that when DIAG = 'U', the diagonal elements of A are +C not referenced either, but are assumed to be unity. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= max(1,M) when SIDE = 'L'; +C LDA >= max(1,N) when SIDE = 'R'. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand side matrix B. +C On exit, if INFO = 0, the leading M-by-N part of this +C array contains the solution matrix X. +C Otherwise, this array is not modified by the routine. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= max(1,M). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal of the condition number of the matrix A, +C computed as RCOND = 1/(norm(A) * norm(inv(A))). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the matrix A. If the user sets TOL > 0, then the given +C value of TOL is used as a lower bound for the reciprocal +C condition number of that matrix; a matrix whose estimated +C condition number is less than 1/TOL is considered to be +C nonsingular. If the user sets TOL <= 0, then an implicitly +C computed, default tolerance, defined by TOLDEF = k*k*EPS, +C is used instead, where EPS is the machine precision (see +C LAPACK Library routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (k) +C +C DWORK DOUBLE PRECISION array, dimension (3*k) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix A is numerically singular, i.e. the +C condition number estimate of A (in the specified +C norm) exceeds 1/TOL. +C +C METHOD +C +C An estimate of the reciprocal of the condition number of the +C triangular matrix A (in the specified norm) is computed, and if +C this estimate is larger then the given (or default) tolerance, +C the specified matrix equation is solved using Level 3 BLAS +C routine DTRSM. +C +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires k N/2 operations. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C February 20, 1998. +C +C KEYWORDS +C +C Condition number, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DIAG, NORM, SIDE, TRANS, UPLO + INTEGER INFO, LDA, LDB, M, N + DOUBLE PRECISION ALPHA, RCOND, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LSIDE, ONENRM + INTEGER NROWA + DOUBLE PRECISION TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DTRCON, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C + LSIDE = LSAME( SIDE, 'L' ) + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) +C +C Test the input scalar arguments. +C + INFO = 0 + IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = -1 + ELSE IF( ( .NOT.LSAME( UPLO, 'U' ) ).AND. + $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = -2 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN + INFO = -3 + ELSE IF( ( .NOT.LSAME( DIAG, 'U' ) ).AND. + $ ( .NOT.LSAME( DIAG, 'N' ) ) )THEN + INFO = -4 + ELSE IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -5 + ELSE IF( M.LT.0 )THEN + INFO = -6 + ELSE IF( N.LT.0 )THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = -12 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( NROWA.EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DBLE( NROWA*NROWA )*DLAMCH( 'Epsilon' ) +C + CALL DTRCON( NORM, UPLO, DIAG, NROWA, A, LDA, RCOND, DWORK, + $ IWORK, INFO ) +C + IF ( RCOND.GT.TOLDEF ) THEN + CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, LDA, B, + $ LDB ) + ELSE + INFO = 1 + END IF +C *** Last line of MB02OD *** + END diff --git a/mex/sources/libslicot/MB02PD.f b/mex/sources/libslicot/MB02PD.f new file mode 100644 index 000000000..e8fb4a9a8 --- /dev/null +++ b/mex/sources/libslicot/MB02PD.f @@ -0,0 +1,553 @@ + SUBROUTINE MB02PD( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, + $ IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/MB02QD.f b/mex/sources/libslicot/MB02QD.f new file mode 100644 index 000000000..610c25043 --- /dev/null +++ b/mex/sources/libslicot/MB02QD.f @@ -0,0 +1,502 @@ + SUBROUTINE MB02QD( JOB, INIPER, M, N, NRHS, RCOND, SVLMAX, A, LDA, + $ B, LDB, Y, JPVT, RANK, SVAL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a solution, optionally corresponding to specified free +C elements, to a real linear least squares problem: +C +C minimize || A * X - B || +C +C using a complete orthogonal factorization of the M-by-N matrix A, +C which may be rank-deficient. +C +C Several right hand side vectors b and solution vectors x can be +C handled in a single call; they are stored as the columns of the +C M-by-NRHS right hand side matrix B and the N-by-NRHS solution +C matrix X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies whether or not a standard least squares solution +C must be computed, as follows: +C = 'L': Compute a standard least squares solution (Y = 0); +C = 'F': Compute a solution with specified free elements +C (given in Y). +C +C INIPER CHARACTER*1 +C Specifies whether an initial column permutation, defined +C by JPVT, must be performed, as follows: +C = 'P': Perform an initial column permutation; +C = 'N': Do not perform an initial column permutation. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides, i.e., the number of +C columns of the matrices B and X. NRHS >= 0. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix C, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of C +C (for instance, the Frobenius norm of C). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the leading M-by-N part of this array contains +C details of its complete orthogonal factorization: +C the leading RANK-by-RANK upper triangular part contains +C the upper triangular factor T11 (see METHOD); +C the elements below the diagonal, with the entries 2 to +C min(M,N)+1 of the array DWORK, represent the orthogonal +C matrix Q as a product of min(M,N) elementary reflectors +C (see METHOD); +C the elements of the subarray A(1:RANK,RANK+1:N), with the +C next RANK entries of the array DWORK, represent the +C orthogonal matrix Z as a product of RANK elementary +C reflectors (see METHOD). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,NRHS) +C On entry, the leading M-by-NRHS part of this array must +C contain the right hand side matrix B. +C On exit, the leading N-by-NRHS part of this array contains +C the solution matrix X. +C If M >= N and RANK = N, the residual sum-of-squares for +C the solution in the i-th column is given by the sum of +C squares of elements N+1:M in that column. +C If NRHS = 0, this array is not referenced, and the routine +C returns the effective rank of A, and its QR factorization. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,M,N). +C +C Y (input) DOUBLE PRECISION array, dimension ( N*NRHS ) +C If JOB = 'F', the elements Y(1:(N-RANK)*NRHS) are used as +C free elements in computing the solution (see METHOD). +C The remaining elements are not referenced. +C If JOB = 'L', or NRHS = 0, this array is not referenced. +C +C JPVT (input/output) INTEGER array, dimension (N) +C On entry with INIPER = 'P', if JPVT(i) <> 0, the i-th +C column of A is an initial column, otherwise it is a free +C column. Before the QR factorization of A, all initial +C columns are permuted to the leading positions; only the +C remaining free columns are moved as a result of column +C pivoting during the factorization. +C If INIPER = 'N', JPVT need not be set on entry. +C On exit, if JPVT(i) = k, then the i-th column of A*P +C was the k-th column of A. +C +C RANK (output) INTEGER +C The effective rank of A, i.e., the order of the submatrix +C R11. This is the same as the order of the submatrix T11 +C in the complete orthogonal factorization of A. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R11: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension LDWORK +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and the entries 2 to min(M,N) + RANK + 1 +C contain the scalar factors of the elementary reflectors +C used in the complete orthogonal factorization of A. +C Among the entries 2 to min(M,N) + 1, only the first RANK +C elements are useful, if INIPER = 'N'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( min(M,N)+3*N+1, 2*min(M,N)+NRHS ) +C For optimum performance LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If INIPER = 'P', the routine first computes a QR factorization +C with column pivoting: +C A * P = Q * [ R11 R12 ] +C [ 0 R22 ] +C with R11 defined as the largest leading submatrix whose estimated +C condition number is less than 1/RCOND. The order of R11, RANK, +C is the effective rank of A. +C If INIPER = 'N', the effective rank is estimated during a +C truncated QR factorization (with column pivoting) process, and +C the submatrix R22 is not upper triangular, but full and of small +C norm. (See SLICOT Library routines MB03OD or MB03OY, respectively, +C for further details.) +C +C Then, R22 is considered to be negligible, and R12 is annihilated +C by orthogonal transformations from the right, arriving at the +C complete orthogonal factorization: +C A * P = Q * [ T11 0 ] * Z +C [ 0 0 ] +C The solution is then +C X = P * Z' [ inv(T11)*Q1'*B ] +C [ Y ] +C where Q1 consists of the first RANK columns of Q, and Y contains +C free elements (if JOB = 'F'), or is zero (if JOB = 'L'). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C FURTHER COMMENTS +C +C Significant gain in efficiency is possible for small-rank problems +C using truncated QR factorization (option INIPER = 'N'). +C +C CONTRIBUTORS +C +C P.Hr. Petkov, Technical University of Sofia, Oct. 1998, +C modification of the LAPACK routine DGELSX. +C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library +C version. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Least squares problems, QR factorization. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO, ONE, DONE, NTDONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO, + $ NTDONE = ONE ) +C .. +C .. Scalar Arguments .. + CHARACTER INIPER, JOB + INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), + $ SVAL( 3 ), Y ( * ) +C .. +C .. Local Scalars .. + LOGICAL LEASTS, PERMUT + INTEGER I, IASCL, IBSCL, J, K, MAXWRK, MINWRK, MN + DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM, T1, T2 +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, DLACPY, DLASCL, DLASET, DORMQR, DORMRZ, + $ DTRSM, DTZRZF, MB03OD, MB03OY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. +C .. Executable Statements .. +C + MN = MIN( M, N ) + LEASTS = LSAME( JOB, 'L' ) + PERMUT = LSAME( INIPER, 'P' ) +C +C Test the input scalar arguments. +C + INFO = 0 + MINWRK = MAX( MN + 3*N + 1, 2*MN + NRHS ) + IF( .NOT. ( LEASTS .OR. LSAME( JOB, 'F' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( PERMUT .OR. LSAME( INIPER, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -5 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -6 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MINWRK ) THEN + INFO = -17 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MN.EQ.0 ) THEN + RANK = 0 + DWORK( 1 ) = ONE + RETURN + END IF +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'M', M, N, A, LDA, DWORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +C +C Matrix all zero. Return zero solution. +C + IF( NRHS.GT.0 ) + $ CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) + RANK = 0 + DWORK( 1 ) = ONE + RETURN + END IF +C + IF( NRHS.GT.0 ) THEN + BNRM = DLANGE( 'M', M, NRHS, B, LDB, DWORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF + END IF +C +C Compute a rank-revealing QR factorization of A and estimate its +C effective rank using incremental condition estimation: +C A * P = Q * R. +C Workspace need min(M,N)+3*N+1; +C prefer min(M,N)+2*N+N*NB. +C Details of Householder transformations stored in DWORK(1:MN). +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MAXWRK = MINWRK + IF( PERMUT ) THEN + CALL MB03OD( 'Q', M, N, A, LDA, JPVT, RCOND, SVLMAX, + $ DWORK( 1 ), RANK, SVAL, DWORK( MN+1 ), LDWORK-MN, + $ INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( MN+1 ) ) + MN ) + ELSE + CALL MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ DWORK( 1 ), DWORK( MN+1 ), INFO ) + END IF +C +C Logically partition R = [ R11 R12 ] +C [ 0 R22 ], +C where R11 = R(1:RANK,1:RANK). +C +C [R11,R12] = [ T11, 0 ] * Z. +C +C Details of Householder transformations stored in DWORK(MN+1:2*MN). +C Workspace need 3*min(M,N); +C prefer 2*min(M,N)+min(M,N)*NB. +C + IF( RANK.LT.N ) THEN + CALL DTZRZF( RANK, N, A, LDA, DWORK( MN+1 ), DWORK( 2*MN+1 ), + $ LDWORK-2*MN, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) + END IF +C + IF( NRHS.GT.0 ) THEN +C +C B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS). +C +C Workspace: need 2*min(M,N)+NRHS; +C prefer min(M,N)+NRHS*NB. +C + CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, + $ DWORK( 1 ), B, LDB, DWORK( 2*MN+1 ), LDWORK-2*MN, + $ INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) +C +C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, + $ NRHS, ONE, A, LDA, B, LDB ) +C + IF( RANK.LT.N ) THEN +C +C Set B(RANK+1:N,1:NRHS). +C + IF( LEASTS ) THEN + CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, + $ B(RANK+1,1), LDB ) + ELSE + CALL DLACPY( 'Full', N-RANK, NRHS, Y, N-RANK, + $ B(RANK+1,1), LDB ) + END IF +C +C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). +C +C Workspace need 2*min(M,N)+NRHS; +C prefer 2*min(M,N)+NRHS*NB. +C + CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, + $ LDA, DWORK( MN+1 ), B, LDB, DWORK( 2*MN+1 ), + $ LDWORK-2*MN, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( 2*MN+1 ) ) + 2*MN ) + END IF +C +C Additional workspace: NRHS. +C +C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). +C + DO 50 J = 1, NRHS + DO 20 I = 1, N + DWORK( 2*MN+I ) = NTDONE + 20 CONTINUE + DO 40 I = 1, N + IF( DWORK( 2*MN+I ).EQ.NTDONE ) THEN + IF( JPVT( I ).NE.I ) THEN + K = I + T1 = B( K, J ) + T2 = B( JPVT( K ), J ) + 30 CONTINUE + B( JPVT( K ), J ) = T1 + DWORK( 2*MN+K ) = DONE + T1 = T2 + K = JPVT( K ) + T2 = B( JPVT( K ), J ) + IF( JPVT( K ).NE.I ) + $ GO TO 30 + B( I, J ) = T1 + DWORK( 2*MN+K ) = DONE + END IF + END IF + 40 CONTINUE + 50 CONTINUE +C +C Undo scaling for B. +C + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + END IF + END IF +C +C Undo scaling for A. +C + IF( IASCL.EQ.1 ) THEN + IF( NRHS.GT.0 ) + $ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + IF( NRHS.GT.0 ) + $ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA, + $ INFO ) + END IF +C + DO 60 I = MN + RANK, 1, -1 + DWORK( I+1 ) = DWORK( I ) + 60 CONTINUE +C + DWORK( 1 ) = MAXWRK + RETURN +C *** Last line of MB02QD *** + END diff --git a/mex/sources/libslicot/MB02QY.f b/mex/sources/libslicot/MB02QY.f new file mode 100644 index 000000000..329f54d46 --- /dev/null +++ b/mex/sources/libslicot/MB02QY.f @@ -0,0 +1,339 @@ + SUBROUTINE MB02QY( M, N, NRHS, RANK, A, LDA, JPVT, B, LDB, TAU, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine the minimum-norm solution to a real linear least +C squares problem: +C +C minimize || A * X - B ||, +C +C using the rank-revealing QR factorization of a real general +C M-by-N matrix A, computed by SLICOT Library routine MB03OD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C NRHS (input) INTEGER +C The number of columns of the matrix B. NRHS >= 0. +C +C RANK (input) INTEGER +C The effective rank of A, as returned by SLICOT Library +C routine MB03OD. min(M,N) >= RANK >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading min(M,N)-by-N upper trapezoidal +C part of this array contains the triangular factor R, as +C returned by SLICOT Library routine MB03OD. The strict +C lower trapezoidal part of A is not referenced. +C On exit, if RANK < N, the leading RANK-by-RANK upper +C triangular part of this array contains the upper +C triangular matrix R of the complete orthogonal +C factorization of A, and the submatrix (1:RANK,RANK+1:N) +C of this array, with the array TAU, represent the +C orthogonal matrix Z (of the complete orthogonal +C factorization of A), as a product of RANK elementary +C reflectors. +C On exit, if RANK = N, this array is unchanged. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input) INTEGER array, dimension ( N ) +C The recorded permutations performed by SLICOT Library +C routine MB03OD; if JPVT(i) = k, then the i-th column +C of A*P was the k-th column of the original matrix A. +C +C B (input/output) DOUBLE PRECISION array, dimension +C ( LDB, NRHS ) +C On entry, if NRHS > 0, the leading M-by-NRHS part of +C this array must contain the matrix B (corresponding to +C the transformed matrix A, returned by SLICOT Library +C routine MB03OD). +C On exit, if NRHS > 0, the leading N-by-NRHS part of this +C array contains the solution matrix X. +C If M >= N and RANK = N, the residual sum-of-squares +C for the solution in the i-th column is given by the sum +C of squares of elements N+1:M in that column. +C If NRHS = 0, the array B is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= max(1,M,N), if NRHS > 0. +C LDB >= 1, if NRHS = 0. +C +C TAU (output) DOUBLE PRECISION array, dimension ( min(M,N) ) +C The scalar factors of the elementary reflectors. +C If RANK = N, the array TAU is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 1, N, NRHS ). +C For good performance, LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses a QR factorization with column pivoting: +C +C A * P = Q * R = Q * [ R11 R12 ], +C [ 0 R22 ] +C +C where R11 is an upper triangular submatrix of estimated rank +C RANK, the effective rank of A. The submatrix R22 can be +C considered as negligible. +C +C If RANK < N, then R12 is annihilated by orthogonal +C transformations from the right, arriving at the complete +C orthogonal factorization: +C +C A * P = Q * [ T11 0 ] * Z. +C [ 0 0 ] +C +C The minimum-norm solution is then +C +C X = P * Z' [ inv(T11)*Q1'*B ], +C [ 0 ] +C +C where Q1 consists of the first RANK columns of Q. +C +C The input data for MB02QY are the transformed matrices Q' * A +C (returned by SLICOT Library routine MB03OD) and Q' * B. +C Matrix Q is not needed. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Least squares solutions; QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), TAU( * ) +C .. Local Scalars .. + INTEGER I, IASCL, IBSCL, J, MN + DOUBLE PRECISION ANRM, BIGNUM, BNRM, MAXWRK, SMLNUM +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANTR + EXTERNAL DLAMCH, DLANGE, DLANTR +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLASCL, DLASET, DORMRZ, DTRSM, + $ DTZRZF, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C + MN = MIN( M, N ) +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( RANK.LT.0 .OR. RANK.GT.MN ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.1 .OR. ( NRHS.GT.0 .AND. LDB.LT.MAX( M, N ) ) ) + $ THEN + INFO = -9 + ELSE IF( LDWORK.LT.MAX( 1, N, NRHS ) ) THEN + INFO = -12 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02QY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( MN, NRHS ).EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Logically partition R = [ R11 R12 ], +C [ 0 R22 ] +C +C where R11 = R(1:RANK,1:RANK). If RANK = N, let T11 = R11. +C + MAXWRK = DBLE( N ) + IF( RANK.LT.N ) THEN +C +C Get machine parameters. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Scale A, B if max entries outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANTR( 'MaxNorm', 'Upper', 'Non-unit', RANK, N, A, LDA, + $ DWORK ) + IASCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, RANK, N, A, LDA, + $ INFO ) + IASCL = 1 + ELSE IF( ANRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, RANK, N, A, LDA, + $ INFO ) + IASCL = 2 + ELSE IF( ANRM.EQ.ZERO ) THEN +C +C Matrix all zero. Return zero solution. +C + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, B, LDB ) + DWORK( 1 ) = ONE + RETURN + END IF +C + BNRM = DLANGE( 'MaxNorm', M, NRHS, B, LDB, DWORK ) + IBSCL = 0 + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN +C +C Scale matrix norm up to SMLNUM. +C + CALL DLASCL( 'General', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 1 + ELSE IF( BNRM.GT.BIGNUM ) THEN +C +C Scale matrix norm down to BIGNUM. +C + CALL DLASCL( 'General', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, + $ INFO ) + IBSCL = 2 + END IF +C +C [R11,R12] = [ T11, 0 ] * Z. +C Details of Householder rotations are stored in TAU. +C Workspace need RANK, prefer RANK*NB. +C + CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, LDWORK, INFO ) + MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) + END IF +C +C B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS). +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK, + $ NRHS, ONE, A, LDA, B, LDB ) +C + IF( RANK.LT.N ) THEN +C + CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, B( RANK+1, 1 ), + $ LDB ) +C +C B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS). +C Workspace need NRHS, prefer NRHS*NB. +C + CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A, + $ LDA, TAU, B, LDB, DWORK, LDWORK, INFO ) + MAXWRK = MAX( MAXWRK, DWORK( 1 ) ) +C +C Undo scaling. +C + IF( IASCL.EQ.1 ) THEN + CALL DLASCL( 'General', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'Upper', 0, 0, SMLNUM, ANRM, RANK, RANK, A, + $ LDA, INFO ) + ELSE IF( IASCL.EQ.2 ) THEN + CALL DLASCL( 'General', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, + $ INFO ) + CALL DLASCL( 'Upper', 0, 0, BIGNUM, ANRM, RANK, RANK, A, + $ LDA, INFO ) + END IF + IF( IBSCL.EQ.1 ) THEN + CALL DLASCL( 'General', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + ELSE IF( IBSCL.EQ.2 ) THEN + CALL DLASCL( 'General', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, + $ INFO ) + END IF + END IF +C +C B(1:N,1:NRHS) := P * B(1:N,1:NRHS). +C Workspace N. +C + DO 20 J = 1, NRHS +C + DO 10 I = 1, N + DWORK( JPVT( I ) ) = B( I, J ) + 10 CONTINUE +C + CALL DCOPY( N, DWORK, 1, B( 1, J ), 1 ) + 20 CONTINUE +C + DWORK( 1 ) = MAXWRK + RETURN +C +C *** Last line of MB02QY *** + END diff --git a/mex/sources/libslicot/MB02RD.f b/mex/sources/libslicot/MB02RD.f new file mode 100644 index 000000000..d524e7f9b --- /dev/null +++ b/mex/sources/libslicot/MB02RD.f @@ -0,0 +1,197 @@ + SUBROUTINE MB02RD( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of linear equations +C H * X = B or H' * X = B +C with an upper Hessenberg N-by-N matrix H using the LU +C factorization computed by MB02SD. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies the form of the system of equations: +C = 'N': H * X = B (No transpose) +C = 'T': H'* X = B (Transpose) +C = 'C': H'* X = B (Conjugate transpose = Transpose) +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides, i.e., the number of +C columns of the matrix B. NRHS >= 0. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,N) +C The factors L and U from the factorization H = P*L*U +C as computed by MB02SD. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices from MB02SD; for 1<=i<=N, row i of the +C matrix was interchanged with row IPIV(i). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,NRHS) +C On entry, the right hand side matrix B. +C On exit, the solution matrix X. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C Error Indicator +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses the factorization +C H = P * L * U +C where P is a permutation matrix, L is lower triangular with unit +C diagonal elements (and one nonzero subdiagonal), and U is upper +C triangular. +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N x NRHS ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDB, LDH, N, NRHS +C .. +C .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION B( LDB, * ), H( LDH, * ) +C .. Local Scalars .. + LOGICAL NOTRAN + INTEGER J, JP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DSWAP, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +C + IF( NOTRAN ) THEN +C +C Solve H * X = B. +C +C Solve L * X = B, overwriting B with X. +C +C L is represented as a product of permutations and unit lower +C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), +C where each transformation L(i) is a rank-one modification of +C the identity matrix. +C + DO 10 J = 1, N - 1 + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + CALL DAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), + $ LDB ) + 10 CONTINUE +C +C Solve U * X = B, overwriting B with X. +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, H, LDH, B, LDB ) +C + ELSE +C +C Solve H' * X = B. +C +C Solve U' * X = B, overwriting B with X. +C + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, H, LDH, B, LDB ) +C +C Solve L' * X = B, overwriting B with X. +C + DO 20 J = N - 1, 1, -1 + CALL DAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), + $ LDB ) + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL DSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + 20 CONTINUE + END IF +C + RETURN +C *** Last line of MB02RD *** + END diff --git a/mex/sources/libslicot/MB02RZ.f b/mex/sources/libslicot/MB02RZ.f new file mode 100644 index 000000000..a82be52be --- /dev/null +++ b/mex/sources/libslicot/MB02RZ.f @@ -0,0 +1,216 @@ + SUBROUTINE MB02RZ( TRANS, N, NRHS, H, LDH, IPIV, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of linear equations +C H * X = B, H' * X = B or H**H * X = B +C with a complex upper Hessenberg N-by-N matrix H using the LU +C factorization computed by MB02SZ. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies the form of the system of equations: +C = 'N': H * X = B (No transpose) +C = 'T': H'* X = B (Transpose) +C = 'C': H**H * X = B (Conjugate transpose) +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C NRHS (input) INTEGER +C The number of right hand sides, i.e., the number of +C columns of the matrix B. NRHS >= 0. +C +C H (input) COMPLEX*16 array, dimension (LDH,N) +C The factors L and U from the factorization H = P*L*U +C as computed by MB02SZ. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices from MB02SZ; for 1<=i<=N, row i of the +C matrix was interchanged with row IPIV(i). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) +C On entry, the right hand side matrix B. +C On exit, the solution matrix X. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses the factorization +C H = P * L * U +C where P is a permutation matrix, L is lower triangular with unit +C diagonal elements (and one nonzero subdiagonal), and U is upper +C triangular. +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N x NRHS ) complex operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01FW by A.J. Laub, University of +C Southern California, United States of America, May 1980. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Frequency response, Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDB, LDH, N, NRHS +C .. +C .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 B( LDB, * ), H( LDH, * ) +C .. Local Scalars .. + LOGICAL NOTRAN + INTEGER J, JP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL XERBLA, ZAXPY, ZSWAP, ZTRSM +C .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02RZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +C + IF( NOTRAN ) THEN +C +C Solve H * X = B. +C +C Solve L * X = B, overwriting B with X. +C +C L is represented as a product of permutations and unit lower +C triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), +C where each transformation L(i) is a rank-one modification of +C the identity matrix. +C + DO 10 J = 1, N - 1 + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + CALL ZAXPY( NRHS, -H( J+1, J ), B( J, 1 ), LDB, B( J+1, 1 ), + $ LDB ) + 10 CONTINUE +C +C Solve U * X = B, overwriting B with X. +C + CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, H, LDH, B, LDB ) +C + ELSE IF( LSAME( TRANS, 'T' ) ) THEN +C +C Solve H' * X = B. +C +C Solve U' * X = B, overwriting B with X. +C + CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, + $ H, LDH, B, LDB ) +C +C Solve L' * X = B, overwriting B with X. +C + DO 20 J = N - 1, 1, -1 + CALL ZAXPY( NRHS, -H( J+1, J ), B( J+1, 1 ), LDB, B( J, 1 ), + $ LDB ) + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + 20 CONTINUE +C + ELSE +C +C Solve H**H * X = B. +C +C Solve U**H * X = B, overwriting B with X. +C + CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE, + $ H, LDH, B, LDB ) +C +C Solve L**H * X = B, overwriting B with X. +C + DO 30 J = N - 1, 1, -1 + CALL ZAXPY( NRHS, -DCONJG( H( J+1, J ) ), B( J+1, 1 ), LDB, + $ B( J, 1 ), LDB ) + JP = IPIV( J ) + IF( JP.NE.J ) + $ CALL ZSWAP( NRHS, B( JP, 1 ), LDB, B( J, 1 ), LDB ) + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB02RZ *** + END diff --git a/mex/sources/libslicot/MB02SD.f b/mex/sources/libslicot/MB02SD.f new file mode 100644 index 000000000..2c72554ee --- /dev/null +++ b/mex/sources/libslicot/MB02SD.f @@ -0,0 +1,164 @@ + SUBROUTINE MB02SD( N, H, LDH, IPIV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an LU factorization of an n-by-n upper Hessenberg +C matrix H using partial pivoting with row interchanges. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C H (input/output) DOUBLE PRECISION array, dimension (LDH,N) +C On entry, the n-by-n upper Hessenberg matrix to be +C factored. +C On exit, the factors L and U from the factorization +C H = P*L*U; the unit diagonal elements of L are not stored, +C and L is lower bidiagonal. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the matrix +C was interchanged with row IPIV(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, U(i,i) is exactly zero. The +C factorization has been completed, but the factor U +C is exactly singular, and division by zero will occur +C if it is used to solve a system of equations. +C +C METHOD +C +C The factorization has the form +C H = P * L * U +C where P is a permutation matrix, L is lower triangular with unit +C diagonal elements (and one nonzero subdiagonal), and U is upper +C triangular. +C +C This is the right-looking Level 1 BLAS version of the algorithm +C (adapted after DGETF2). +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, +C Jan. 2005. +C +C KEYWORDS +C +C Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDH, N +C .. Array Arguments .. + INTEGER IPIV(*) + DOUBLE PRECISION H(LDH,*) +C .. Local Scalars .. + INTEGER J, JP +C .. External Subroutines .. + EXTERNAL DAXPY, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + DO 10 J = 1, N +C +C Find pivot and test for singularity. +C + JP = J + IF ( J.LT.N ) THEN + IF ( ABS( H( J+1, J ) ).GT.ABS( H( J, J ) ) ) + $ JP = J + 1 + END IF + IPIV( J ) = JP + IF( H( JP, J ).NE.ZERO ) THEN +C +C Apply the interchange to columns J:N. +C + IF( JP.NE.J ) + $ CALL DSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) +C +C Compute element J+1 of J-th column. +C + IF( J.LT.N ) + $ H( J+1, J ) = H( J+1, J )/H( J, J ) +C + ELSE IF( INFO.EQ.0 ) THEN +C + INFO = J + END IF +C + IF( J.LT.N ) THEN +C +C Update trailing submatrix. +C + CALL DAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, + $ H( J+1, J+1 ), LDH ) + END IF + 10 CONTINUE + RETURN +C *** Last line of MB02SD *** + END diff --git a/mex/sources/libslicot/MB02SZ.f b/mex/sources/libslicot/MB02SZ.f new file mode 100644 index 000000000..4643a9189 --- /dev/null +++ b/mex/sources/libslicot/MB02SZ.f @@ -0,0 +1,169 @@ + SUBROUTINE MB02SZ( N, H, LDH, IPIV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an LU factorization of a complex n-by-n upper +C Hessenberg matrix H using partial pivoting with row interchanges. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C H (input/output) COMPLEX*16 array, dimension (LDH,N) +C On entry, the n-by-n upper Hessenberg matrix to be +C factored. +C On exit, the factors L and U from the factorization +C H = P*L*U; the unit diagonal elements of L are not stored, +C and L is lower bidiagonal. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the matrix +C was interchanged with row IPIV(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, U(i,i) is exactly zero. The +C factorization has been completed, but the factor U +C is exactly singular, and division by zero will occur +C if it is used to solve a system of equations. +C +C METHOD +C +C The factorization has the form +C H = P * L * U +C where P is a permutation matrix, L is lower triangular with unit +C diagonal elements (and one nonzero subdiagonal), and U is upper +C triangular. +C +C This is the right-looking Level 2 BLAS version of the algorithm +C (adapted after ZGETF2). +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N ) complex operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01FX by A.J. Laub, University of +C Southern California, United States of America, May 1980. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, +C Jan. 2005. +C +C KEYWORDS +C +C Frequency response, Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LDH, N +C .. Array Arguments .. + INTEGER IPIV(*) + COMPLEX*16 H(LDH,*) +C .. Local Scalars .. + INTEGER J, JP +C .. External Functions .. + DOUBLE PRECISION DCABS1 + EXTERNAL DCABS1 +C .. External Subroutines .. + EXTERNAL XERBLA, ZAXPY, ZSWAP +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02SZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C + DO 10 J = 1, N +C +C Find pivot and test for singularity. +C + JP = J + IF ( J.LT.N ) THEN + IF ( DCABS1( H( J+1, J ) ).GT.DCABS1( H( J, J ) ) ) + $ JP = J + 1 + END IF + IPIV( J ) = JP + IF( H( JP, J ).NE.ZERO ) THEN +C +C Apply the interchange to columns J:N. +C + IF( JP.NE.J ) + $ CALL ZSWAP( N-J+1, H( J, J ), LDH, H( JP, J ), LDH ) +C +C Compute element J+1 of J-th column. +C + IF( J.LT.N ) + $ H( J+1, J ) = H( J+1, J )/H( J, J ) +C + ELSE IF( INFO.EQ.0 ) THEN +C + INFO = J + END IF +C + IF( J.LT.N ) THEN +C +C Update trailing submatrix. +C + CALL ZAXPY( N-J, -H( J+1, J ), H( J, J+1 ), LDH, + $ H( J+1, J+1 ), LDH ) + END IF + 10 CONTINUE + RETURN +C *** Last line of MB02SZ *** + END diff --git a/mex/sources/libslicot/MB02TD.f b/mex/sources/libslicot/MB02TD.f new file mode 100644 index 000000000..865ffbf39 --- /dev/null +++ b/mex/sources/libslicot/MB02TD.f @@ -0,0 +1,236 @@ + SUBROUTINE MB02TD( NORM, N, HNORM, H, LDH, IPIV, RCOND, IWORK, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the reciprocal of the condition number of an upper +C Hessenberg matrix H, in either the 1-norm or the infinity-norm, +C using the LU factorization computed by MB02SD. +C +C ARGUMENTS +C +C Mode Parameters +C +C NORM CHARACTER*1 +C Specifies whether the 1-norm condition number or the +C infinity-norm condition number is required: +C = '1' or 'O': 1-norm; +C = 'I': Infinity-norm. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C HNORM (input) DOUBLE PRECISION +C If NORM = '1' or 'O', the 1-norm of the original matrix H. +C If NORM = 'I', the infinity-norm of the original matrix H. +C +C H (input) DOUBLE PRECISION array, dimension (LDH,N) +C The factors L and U from the factorization H = P*L*U +C as computed by MB02SD. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the matrix +C was interchanged with row IPIV(i). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal of the condition number of the matrix H, +C computed as RCOND = 1/(norm(H) * norm(inv(H))). +C +C Workspace +C +C IWORK DOUBLE PRECISION array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (3*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C An estimate is obtained for norm(inv(H)), and the reciprocal of +C the condition number is computed as +C RCOND = 1 / ( norm(H) * norm(inv(H)) ). +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER NORM + INTEGER INFO, LDH, N + DOUBLE PRECISION HNORM, RCOND +C .. +C .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION DWORK( * ), H( LDH, * ) +C .. Local Scalars .. + LOGICAL ONENRM + CHARACTER NORMIN + INTEGER IX, J, JP, KASE, KASE1 +C + DOUBLE PRECISION HINVNM, SCALE, SMLNUM, T +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLACON, DLATRS, DRSCL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) + IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( HNORM.LT.ZERO ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( HNORM.EQ.ZERO ) THEN + RETURN + END IF +C + SMLNUM = DLAMCH( 'Safe minimum' ) +C +C Estimate the norm of inv(H). +C + HINVNM = ZERO + NORMIN = 'N' + IF( ONENRM ) THEN + KASE1 = 1 + ELSE + KASE1 = 2 + END IF + KASE = 0 + 10 CONTINUE + CALL DLACON( N, DWORK( N+1 ), DWORK, IWORK, HINVNM, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.KASE1 ) THEN +C +C Multiply by inv(L). +C + DO 20 J = 1, N - 1 + JP = IPIV( J ) + T = DWORK( JP ) + IF( JP.NE.J ) THEN + DWORK( JP ) = DWORK( J ) + DWORK( J ) = T + END IF + DWORK( J+1 ) = DWORK( J+1 ) - T * H( J+1, J ) + 20 CONTINUE +C +C Multiply by inv(U). +C + CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ H, LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) + ELSE +C +C Multiply by inv(U'). +C + CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, H, + $ LDH, DWORK, SCALE, DWORK( 2*N+1 ), INFO ) +C +C Multiply by inv(L'). +C + DO 30 J = N - 1, 1, -1 + DWORK( J ) = DWORK( J ) - H( J+1, J ) * DWORK( J+1 ) + JP = IPIV( J ) + IF( JP.NE.J ) THEN + T = DWORK( JP ) + DWORK( JP ) = DWORK( J ) + DWORK( J ) = T + END IF + 30 CONTINUE + END IF +C +C Divide X by 1/SCALE if doing so will not cause overflow. +C + NORMIN = 'Y' + IF( SCALE.NE.ONE ) THEN + IX = IDAMAX( N, DWORK, 1 ) + IF( SCALE.LT.ABS( DWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO + $ ) GO TO 40 + CALL DRSCL( N, SCALE, DWORK, 1 ) + END IF + GO TO 10 + END IF +C +C Compute the estimate of the reciprocal condition number. +C + IF( HINVNM.NE.ZERO ) + $ RCOND = ( ONE / HINVNM ) / HNORM +C + 40 CONTINUE + RETURN +C *** Last line of MB02TD *** + END diff --git a/mex/sources/libslicot/MB02TZ.f b/mex/sources/libslicot/MB02TZ.f new file mode 100644 index 000000000..8cc434d75 --- /dev/null +++ b/mex/sources/libslicot/MB02TZ.f @@ -0,0 +1,247 @@ + SUBROUTINE MB02TZ( NORM, N, HNORM, H, LDH, IPIV, RCOND, DWORK, + $ ZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the reciprocal of the condition number of a complex +C upper Hessenberg matrix H, in either the 1-norm or the +C infinity-norm, using the LU factorization computed by MB02SZ. +C +C ARGUMENTS +C +C Mode Parameters +C +C NORM CHARACTER*1 +C Specifies whether the 1-norm condition number or the +C infinity-norm condition number is required: +C = '1' or 'O': 1-norm; +C = 'I': Infinity-norm. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C HNORM (input) DOUBLE PRECISION +C If NORM = '1' or 'O', the 1-norm of the original matrix H. +C If NORM = 'I', the infinity-norm of the original matrix H. +C +C H (input) COMPLEX*16 array, dimension (LDH,N) +C The factors L and U from the factorization H = P*L*U +C as computed by MB02SZ. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the matrix +C was interchanged with row IPIV(i). +C +C RCOND (output) DOUBLE PRECISION +C The reciprocal of the condition number of the matrix H, +C computed as RCOND = 1/(norm(H) * norm(inv(H))). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C ZWORK COMPLEX*16 array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C An estimate is obtained for norm(inv(H)), and the reciprocal of +C the condition number is computed as +C RCOND = 1 / ( norm(H) * norm(inv(H)) ). +C +C REFERENCES +C +C - +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0( N ) complex operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01FY by A.J. Laub, University of +C Southern California, United States of America, May 1980. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2005. +C +C KEYWORDS +C +C Frequency response, Hessenberg form, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER NORM + INTEGER INFO, LDH, N + DOUBLE PRECISION HNORM, RCOND +C .. +C .. Array Arguments .. + INTEGER IPIV(*) + DOUBLE PRECISION DWORK( * ) + COMPLEX*16 H( LDH, * ), ZWORK( * ) +C .. Local Scalars .. + LOGICAL ONENRM + CHARACTER NORMIN + INTEGER IX, J, JP, KASE, KASE1 +C + DOUBLE PRECISION HINVNM, SCALE, SMLNUM + COMPLEX*16 T, ZDUM +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IZAMAX, LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, ZDRSCL, ZLACON, ZLATRS +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX +C .. +C .. Statement Functions .. + DOUBLE PRECISION CABS1 +C .. +C .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +C .. +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) + IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( HNORM.LT.ZERO ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02TZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + RCOND = ZERO + IF( N.EQ.0 ) THEN + RCOND = ONE + RETURN + ELSE IF( HNORM.EQ.ZERO ) THEN + RETURN + END IF +C + SMLNUM = DLAMCH( 'Safe minimum' ) +C +C Estimate the norm of inv(H). +C + HINVNM = ZERO + NORMIN = 'N' + IF( ONENRM ) THEN + KASE1 = 1 + ELSE + KASE1 = 2 + END IF + KASE = 0 + 10 CONTINUE + CALL ZLACON( N, ZWORK( N+1 ), ZWORK, HINVNM, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.KASE1 ) THEN +C +C Multiply by inv(L). +C + DO 20 J = 1, N - 1 + JP = IPIV( J ) + T = ZWORK( JP ) + IF( JP.NE.J ) THEN + ZWORK( JP ) = ZWORK( J ) + ZWORK( J ) = T + END IF + ZWORK( J+1 ) = ZWORK( J+1 ) - T * H( J+1, J ) + 20 CONTINUE +C +C Multiply by inv(U). +C + CALL ZLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, + $ H, LDH, ZWORK, SCALE, DWORK, INFO ) + ELSE +C +C Multiply by inv(U'). +C + CALL ZLATRS( 'Upper', 'Conjugate transpose', 'Non-unit', + $ NORMIN, N, H, LDH, ZWORK, SCALE, DWORK, INFO ) +C +C Multiply by inv(L'). +C + DO 30 J = N - 1, 1, -1 + ZWORK( J ) = ZWORK( J ) - + $ DCONJG( H( J+1, J ) ) * ZWORK( J+1 ) + JP = IPIV( J ) + IF( JP.NE.J ) THEN + T = ZWORK( JP ) + ZWORK( JP ) = ZWORK( J ) + ZWORK( J ) = T + END IF + 30 CONTINUE + END IF +C +C Divide X by 1/SCALE if doing so will not cause overflow. +C + NORMIN = 'Y' + IF( SCALE.NE.ONE ) THEN + IX = IZAMAX( N, ZWORK, 1 ) + IF( SCALE.LT.CABS1( ZWORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO + $ ) GO TO 40 + CALL ZDRSCL( N, SCALE, ZWORK, 1 ) + END IF + GO TO 10 + END IF +C +C Compute the estimate of the reciprocal condition number. +C + IF( HINVNM.NE.ZERO ) + $ RCOND = ( ONE / HINVNM ) / HNORM +C + 40 CONTINUE + RETURN +C *** Last line of MB02TZ *** + END diff --git a/mex/sources/libslicot/MB02UD.f b/mex/sources/libslicot/MB02UD.f new file mode 100644 index 000000000..101c7426e --- /dev/null +++ b/mex/sources/libslicot/MB02UD.f @@ -0,0 +1,624 @@ + SUBROUTINE MB02UD( FACT, SIDE, TRANS, JOBP, M, N, ALPHA, RCOND, + $ RANK, R, LDR, Q, LDQ, SV, B, LDB, RP, LDRP, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the minimum norm least squares solution of one of the +C following linear systems +C +C op(R)*X = alpha*B, (1) +C X*op(R) = alpha*B, (2) +C +C where alpha is a real scalar, op(R) is either R or its transpose, +C R', R is an L-by-L real upper triangular matrix, B is an M-by-N +C real matrix, and L = M for (1), or L = N for (2). Singular value +C decomposition, R = Q*S*P', is used, assuming that R is rank +C deficient. +C +C ARGUMENTS +C +C Mode Parameters +C +C FACT CHARACTER*1 +C Specifies whether R has been previously factored or not, +C as follows: +C = 'F': R has been factored and its rank and singular +C value decomposition, R = Q*S*P', are available; +C = 'N': R has not been factored and its singular value +C decomposition, R = Q*S*P', should be computed. +C +C SIDE CHARACTER*1 +C Specifies whether op(R) appears on the left or right +C of X as follows: +C = 'L': Solve op(R)*X = alpha*B (op(R) is on the left); +C = 'R': Solve X*op(R) = alpha*B (op(R) is on the right). +C +C TRANS CHARACTER*1 +C Specifies the form of op(R) to be used as follows: +C = 'N': op(R) = R; +C = 'T': op(R) = R'; +C = 'C': op(R) = R'. +C +C JOBP CHARACTER*1 +C Specifies whether or not the pseudoinverse of R is to be +C computed or it is available as follows: +C = 'P': Compute pinv(R), if FACT = 'N', or +C use pinv(R), if FACT = 'F'; +C = 'N': Do not compute or use pinv(R). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix B. N >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar alpha. When alpha is zero then B need not be +C set before entry. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of R. +C Singular values of R satisfying Sv(i) <= RCOND*Sv(1) are +C treated as zero. If RCOND <= 0, then EPS is used instead, +C where EPS is the relative machine precision (see LAPACK +C Library routine DLAMCH). RCOND <= 1. +C RCOND is not used if FACT = 'F'. +C +C RANK (input or output) INTEGER +C The rank of matrix R. +C RANK is an input parameter when FACT = 'F', and an output +C parameter when FACT = 'N'. L >= RANK >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,L) +C On entry, if FACT = 'F', the leading L-by-L part of this +C array must contain the L-by-L orthogonal matrix P' from +C singular value decomposition, R = Q*S*P', of the matrix R; +C if JOBP = 'P', the first RANK rows of P' are assumed to be +C scaled by inv(S(1:RANK,1:RANK)). +C On entry, if FACT = 'N', the leading L-by-L upper +C triangular part of this array must contain the upper +C triangular matrix R. +C On exit, if INFO = 0, the leading L-by-L part of this +C array contains the L-by-L orthogonal matrix P', with its +C first RANK rows scaled by inv(S(1:RANK,1:RANK)), when +C JOBP = 'P'. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,L). +C +C Q (input or output) DOUBLE PRECISION array, dimension +C (LDQ,L) +C On entry, if FACT = 'F', the leading L-by-L part of this +C array must contain the L-by-L orthogonal matrix Q from +C singular value decomposition, R = Q*S*P', of the matrix R. +C If FACT = 'N', this array need not be set on entry, and +C on exit, if INFO = 0, the leading L-by-L part of this +C array contains the orthogonal matrix Q. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,L). +C +C SV (input or output) DOUBLE PRECISION array, dimension (L) +C On entry, if FACT = 'F', the first RANK entries of this +C array must contain the reciprocal of the largest RANK +C singular values of the matrix R, and the last L-RANK +C entries of this array must contain the remaining singular +C values of R sorted in descending order. +C If FACT = 'N', this array need not be set on input, and +C on exit, if INFO = 0, the first RANK entries of this array +C contain the reciprocal of the largest RANK singular values +C of the matrix R, and the last L-RANK entries of this array +C contain the remaining singular values of R sorted in +C descending order. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, if ALPHA <> 0, the leading M-by-N part of this +C array must contain the matrix B. +C On exit, if INFO = 0 and RANK > 0, the leading M-by-N part +C of this array contains the M-by-N solution matrix X. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C RP (input or output) DOUBLE PRECISION array, dimension +C (LDRP,L) +C On entry, if FACT = 'F', JOBP = 'P', and RANK > 0, the +C leading L-by-L part of this array must contain the L-by-L +C matrix pinv(R), the Moore-Penrose pseudoinverse of R. +C On exit, if FACT = 'N', JOBP = 'P', and RANK > 0, the +C leading L-by-L part of this array contains the L-by-L +C matrix pinv(R), the Moore-Penrose pseudoinverse of R. +C If JOBP = 'N', this array is not referenced. +C +C LDRP INTEGER +C The leading dimension of array RP. +C LDRP >= MAX(1,L), if JOBP = 'P'. +C LDRP >= 1, if JOBP = 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; +C if INFO = i, 1 <= i <= L, then DWORK(2:L) contain the +C unconverged superdiagonal elements of an upper bidiagonal +C matrix D whose diagonal is in SV (not necessarily sorted). +C D satisfies R = Q*D*P', so it has the same singular +C values as R, and singular vectors related by Q and P'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,L), if FACT = 'F'; +C LDWORK >= MAX(1,5*L), if FACT = 'N'. +C For optimum performance LDWORK should be larger than +C MAX(1,L,M*N), if FACT = 'F'; +C MAX(1,5*L,M*N), if FACT = 'N'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i = 1:L, the SVD algorithm has failed +C to converge. In this case INFO specifies how many +C superdiagonals did not converge (see the description +C of DWORK); this failure is not likely to occur. +C +C METHOD +C +C The L-by-L upper triangular matrix R is factored as R = Q*S*P', +C if FACT = 'N', using SLICOT Library routine MB03UD, where Q and P +C are L-by-L orthogonal matrices and S is an L-by-L diagonal matrix +C with non-negative diagonal elements, SV(1), SV(2), ..., SV(L), +C ordered decreasingly. Then, the effective rank of R is estimated, +C and matrix (or matrix-vector) products and scalings are used to +C compute X. If FACT = 'F', only matrix (or matrix-vector) products +C and scalings are performed. +C +C FURTHER COMMENTS +C +C Option JOBP = 'P' should be used only if the pseudoinverse is +C really needed. Usually, it is possible to avoid the use of +C pseudoinverse, by computing least squares solutions. +C The routine uses BLAS 3 calculations if LDWORK >= M*N, and BLAS 2 +C calculations, otherwise. No advantage of any additional workspace +C larger than L is taken for matrix products, but the routine can +C be called repeatedly for chunks of columns of B, if LDWORK < M*N. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute of Informatics, Bucharest, Oct. 1999. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Bidiagonalization, orthogonal transformation, singular value +C decomposition, singular values, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER FACT, JOBP, SIDE, TRANS + INTEGER INFO, LDB, LDQ, LDR, LDRP, LDWORK, M, N, RANK + DOUBLE PRECISION ALPHA, RCOND +C .. Array Arguments .. + DOUBLE PRECISION B(LDB,*), DWORK(*), Q(LDQ,*), R(LDR,*), + $ RP(LDRP,*), SV(*) +C .. Local Scalars .. + LOGICAL LEFT, NFCT, PINV, TRAN + CHARACTER*1 NTRAN + INTEGER I, L, MAXWRK, MINWRK, MN + DOUBLE PRECISION TOLL +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLACPY, DLASET, MB01SD, + $ MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + INFO = 0 + NFCT = LSAME( FACT, 'N' ) + LEFT = LSAME( SIDE, 'L' ) + PINV = LSAME( JOBP, 'P' ) + TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + IF( LEFT ) THEN + L = M + ELSE + L = N + END IF + MN = M*N + IF( .NOT.NFCT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -3 + ELSE IF( .NOT.PINV .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( NFCT .AND. RCOND.GT.ONE ) THEN + INFO = -8 + ELSE IF( .NOT.NFCT .AND. ( RANK.LT.ZERO .OR. RANK.GT.L ) ) THEN + INFO = -9 + ELSE IF( LDR.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN + INFO = -13 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDRP.LT.1 .OR. ( PINV .AND. LDRP.LT.L ) ) THEN + INFO = -18 + END IF +C +C Compute workspace +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately following +C subroutine, as returned by ILAENV.) +C + MINWRK = 1 + IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. L.GT.0 ) THEN + MINWRK = MAX( 1, L ) + MAXWRK = MAX( MINWRK, MN ) + IF( NFCT ) THEN + MAXWRK = MAX( MAXWRK, 3*L+2*L* + $ ILAENV( 1, 'DGEBRD', ' ', L, L, -1, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*L+L* + $ ILAENV( 1, 'DORGBR', 'Q', L, L, L, -1 ) ) + MAXWRK = MAX( MAXWRK, 3*L+L* + $ ILAENV( 1, 'DORGBR', 'P', L, L, L, -1 ) ) + MINWRK = MAX( 1, 5*L ) + MAXWRK = MAX( MAXWRK, MINWRK ) + END IF + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -20 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 ) THEN + IF( NFCT ) + $ RANK = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( NFCT ) THEN +C +C Compute the SVD of R, R = Q*S*P'. +C Matrix Q is computed in the array Q, and P' overwrites R. +C Workspace: need 5*L; +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', L, R, LDR, Q, LDQ, SV, + $ DWORK, LDWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN +C +C Use the default tolerance, if required. +C + TOLL = RCOND + IF( TOLL.LE.ZERO ) + $ TOLL = DLAMCH( 'Precision' ) + TOLL = MAX( TOLL*SV(1), DLAMCH( 'Safe minimum' ) ) +C +C Estimate the rank of R. +C + DO 10 I = 1, L + IF ( TOLL.GT.SV(I) ) + $ GO TO 20 + 10 CONTINUE +C + I = L + 1 + 20 CONTINUE + RANK = I - 1 +C + DO 30 I = 1, RANK + SV(I) = ONE / SV(I) + 30 CONTINUE +C + IF( PINV .AND. RANK.GT.0 ) THEN +C +C Compute pinv(S)'*P' in R. +C + CALL MB01SD( 'Row scaling', RANK, L, R, LDR, SV, SV ) +C +C Compute pinv(R) = P*pinv(S)*Q' in RP. +C + CALL DGEMM( 'Transpose', 'Transpose', L, L, RANK, ONE, R, + $ LDR, Q, LDQ, ZERO, RP, LDRP ) + END IF + END IF +C +C Return if min(M,N) = 0 or RANK = 0. +C + IF( MIN( M, N ).EQ.0 .OR. RANK.EQ.0 ) THEN + DWORK(1) = MAXWRK + RETURN + END IF +C +C Set X = 0 if alpha = 0. +C + IF( ALPHA.EQ.ZERO ) THEN + CALL DLASET( 'Full', M, N, ZERO, ZERO, B, LDB ) + DWORK(1) = MAXWRK + RETURN + END IF +C + IF( PINV ) THEN +C + IF( LEFT ) THEN +C +C Compute alpha*op(pinv(R))*B in workspace and save it in B. +C Workspace: need M (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + CALL DGEMM( TRANS, 'NoTranspose', M, N, M, ALPHA, + $ RP, LDRP, B, LDB, ZERO, DWORK, M ) + CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) + ELSE +C + DO 40 I = 1, N + CALL DGEMV( TRANS, M, M, ALPHA, RP, LDRP, B(1,I), 1, + $ ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 40 CONTINUE +C + END IF + ELSE +C +C Compute alpha*B*op(pinv(R)) in workspace and save it in B. +C Workspace: need N (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + CALL DGEMM( 'NoTranspose', TRANS, M, N, N, ALPHA, B, LDB, + $ RP, LDRP, ZERO, DWORK, M ) + CALL DLACPY( 'Full', M, N, DWORK, M, B, LDB ) + ELSE +C + IF( TRAN ) THEN + NTRAN = 'N' + ELSE + NTRAN = 'T' + END IF +C + DO 50 I = 1, M + CALL DGEMV( NTRAN, N, N, ALPHA, RP, LDRP, B(I,1), LDB, + $ ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 50 CONTINUE +C + END IF + END IF +C + ELSE +C + IF( LEFT ) THEN +C +C Compute alpha*P*pinv(S)*Q'*B or alpha*Q*pinv(S)'*P'*B. +C Workspace: need M (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + IF( TRAN ) THEN +C +C Compute alpha*P'*B in workspace. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, + $ ALPHA, R, LDR, B, LDB, ZERO, DWORK, M ) +C +C Compute alpha*pinv(S)'*P'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, + $ SV ) +C +C Compute alpha*Q*pinv(S)'*P'*B. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, + $ ONE, Q, LDQ, DWORK, M, ZERO, B, LDB ) + ELSE +C +C Compute alpha*Q'*B in workspace. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, + $ ALPHA, Q, LDQ, B, LDB, ZERO, DWORK, M ) +C +C Compute alpha*pinv(S)*Q'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, DWORK, M, SV, + $ SV ) +C +C Compute alpha*P*pinv(S)*Q'*B. +C + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, RANK, + $ ONE, R, LDR, DWORK, M, ZERO, B, LDB ) + END IF + ELSE + IF( TRAN ) THEN +C +C Compute alpha*P'*B in B using workspace. +C + DO 60 I = 1, N + CALL DGEMV( 'NoTranspose', M, M, ALPHA, R, LDR, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 60 CONTINUE +C +C Compute alpha*pinv(S)'*P'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) +C +C Compute alpha*Q*pinv(S)'*P'*B in B using workspace. +C + DO 70 I = 1, N + CALL DGEMV( 'NoTranspose', M, RANK, ONE, Q, LDQ, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 70 CONTINUE + ELSE +C +C Compute alpha*Q'*B in B using workspace. +C + DO 80 I = 1, N + CALL DGEMV( 'Transpose', M, M, ALPHA, Q, LDQ, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 80 CONTINUE +C +C Compute alpha*pinv(S)*Q'*B. +C + CALL MB01SD( 'Row scaling', RANK, N, B, LDB, SV, SV ) +C +C Compute alpha*P*pinv(S)*Q'*B in B using workspace. +C + DO 90 I = 1, N + CALL DGEMV( 'Transpose', RANK, M, ONE, R, LDR, + $ B(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, B(1,I), 1 ) + 90 CONTINUE + END IF + END IF + ELSE +C +C Compute alpha*B*P*pinv(S)*Q' or alpha*B*Q*pinv(S)'*P'. +C Workspace: need N (BLAS 2); +C prefer M*N (BLAS 3). +C + IF( LDWORK.GE.MN ) THEN + IF( TRAN ) THEN +C +C Compute alpha*B*Q in workspace. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, + $ ALPHA, B, LDB, Q, LDQ, ZERO, DWORK, M ) +C +C Compute alpha*B*Q*pinv(S)'. +C + CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, + $ SV ) +C +C Compute alpha*B*Q*pinv(S)'*P' in B. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, RANK, + $ ONE, DWORK, M, R, LDR, ZERO, B, LDB ) + ELSE +C +C Compute alpha*B*P in workspace. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, + $ ALPHA, B, LDB, R, LDR, ZERO, DWORK, M ) +C +C Compute alpha*B*P*pinv(S). +C + CALL MB01SD( 'Column scaling', M, RANK, DWORK, M, SV, + $ SV ) +C +C Compute alpha*B*P*pinv(S)*Q' in B. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, RANK, + $ ONE, DWORK, M, Q, LDQ, ZERO, B, LDB ) + END IF + ELSE + IF( TRAN ) THEN +C +C Compute alpha*B*Q in B using workspace. +C + DO 100 I = 1, M + CALL DGEMV( 'Transpose', N, N, ALPHA, Q, LDQ, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 100 CONTINUE +C +C Compute alpha*B*Q*pinv(S)'. +C + CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, + $ SV ) +C +C Compute alpha*B*Q*pinv(S)'*P' in B using workspace. +C + DO 110 I = 1, M + CALL DGEMV( 'Transpose', RANK, N, ONE, R, LDR, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 110 CONTINUE +C + ELSE +C +C Compute alpha*B*P in B using workspace. +C + DO 120 I = 1, M + CALL DGEMV( 'NoTranspose', N, N, ALPHA, R, LDR, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 120 CONTINUE +C +C Compute alpha*B*P*pinv(S). +C + CALL MB01SD( 'Column scaling', M, RANK, B, LDB, SV, + $ SV ) +C +C Compute alpha*B*P*pinv(S)*Q' in B using workspace. +C + DO 130 I = 1, M + CALL DGEMV( 'NoTranspose', N, RANK, ONE, Q, LDQ, + $ B(I,1), LDB, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, B(I,1), LDB ) + 130 CONTINUE + END IF + END IF + END IF + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK(1) = MAXWRK +C + RETURN +C *** Last line of MB02UD *** + END diff --git a/mex/sources/libslicot/MB02UU.f b/mex/sources/libslicot/MB02UU.f new file mode 100644 index 000000000..649cc5139 --- /dev/null +++ b/mex/sources/libslicot/MB02UU.f @@ -0,0 +1,162 @@ + SUBROUTINE MB02UU( N, A, LDA, RHS, IPIV, JPIV, SCALE ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for x in A * x = scale * RHS, using the LU factorization +C of the N-by-N matrix A computed by SLICOT Library routine MB02UV. +C The factorization has the form A = P * L * U * Q, where P and Q +C are permutation matrices, L is unit lower triangular and U is +C upper triangular. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. +C +C A (input) DOUBLE PRECISION array, dimension (LDA, N) +C The leading N-by-N part of this array must contain +C the LU part of the factorization of the matrix A computed +C by SLICOT Library routine MB02UV: A = P * L * U * Q. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1, N). +C +C RHS (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the right hand side +C of the system. +C On exit, this array contains the solution of the system. +C +C IPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the +C matrix has been interchanged with row IPIV(i). +C +C JPIV (input) INTEGER array, dimension (N) +C The pivot indices; for 1 <= j <= N, column j of the +C matrix has been interchanged with column JPIV(j). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, chosen 0 < SCALE <= 1 to prevent +C overflow in the solution. +C +C FURTHER COMMENTS +C +C In the interest of speed, this routine does not check the input +C for errors. It should only be used if the order of the matrix A +C is very small. +C +C CONTRIBUTOR +C +C Bo Kagstrom and P. Poromaa, Univ. of Umea, Sweden, Nov. 1993. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) +C .. Scalar Arguments .. + INTEGER LDA, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), RHS( * ) +C .. Local Scalars .. + INTEGER I, IP, J + DOUBLE PRECISION BIGNUM, EPS, FACTOR, SMLNUM, TEMP +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. External Subroutines .. + EXTERNAL DAXPY, DLABAD, DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C +C Set constants to control owerflow. +C + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Apply permutations IPIV to RHS. +C + DO 20 I = 1, N - 1 + IP = IPIV(I) + IF ( IP.NE.I ) THEN + TEMP = RHS(I) + RHS(I) = RHS(IP) + RHS(IP) = TEMP + ENDIF + 20 CONTINUE +C +C Solve for L part. +C + DO 40 I = 1, N - 1 + CALL DAXPY( N-I, -RHS(I), A(I+1, I), 1, RHS(I+1), 1 ) + 40 CONTINUE +C +C Solve for U part. +C +C Check for scaling. +C + FACTOR = TWO * DBLE( N ) + I = 1 + 60 CONTINUE + IF ( ( FACTOR * SMLNUM ) * ABS( RHS(I) ) .LE. ABS( A(I, I) ) ) + $ THEN + I = I + 1 + IF ( I .LE. N ) GO TO 60 + SCALE = ONE + ELSE + SCALE = ( ONE / FACTOR ) / ABS( RHS( IDAMAX( N, RHS, 1 ) ) ) + CALL DSCAL( N, SCALE, RHS, 1 ) + END IF +C + DO 100 I = N, 1, -1 + TEMP = ONE / A(I, I) + RHS(I) = RHS(I) * TEMP + DO 80 J = I + 1, N + RHS(I) = RHS(I) - RHS(J) * ( A(I, J) * TEMP ) + 80 CONTINUE + 100 CONTINUE +C +C Apply permutations JPIV to the solution (RHS). +C + DO 120 I = N - 1, 1, -1 + IP = JPIV(I) + IF ( IP.NE.I ) THEN + TEMP = RHS(I) + RHS(I) = RHS(IP) + RHS(IP) = TEMP + ENDIF + 120 CONTINUE +C + RETURN +C *** Last line of MB02UU *** + END diff --git a/mex/sources/libslicot/MB02UV.f b/mex/sources/libslicot/MB02UV.f new file mode 100644 index 000000000..61e5bbc73 --- /dev/null +++ b/mex/sources/libslicot/MB02UV.f @@ -0,0 +1,195 @@ + SUBROUTINE MB02UV( N, A, LDA, IPIV, JPIV, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an LU factorization, using complete pivoting, of the +C N-by-N matrix A. The factorization has the form A = P * L * U * Q, +C where P and Q are permutation matrices, L is lower triangular with +C unit diagonal elements and U is upper triangular. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA, N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A to be factored. +C On exit, the leading N-by-N part of this array contains +C the factors L and U from the factorization A = P*L*U*Q; +C the unit diagonal elements of L are not stored. If U(k, k) +C appears to be less than SMIN, U(k, k) is given the value +C of SMIN, giving a nonsingular perturbed system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1, N). +C +C IPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= i <= N, row i of the +C matrix has been interchanged with row IPIV(i). +C +C JPIV (output) INTEGER array, dimension (N) +C The pivot indices; for 1 <= j <= N, column j of the +C matrix has been interchanged with column JPIV(j). +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C = k: U(k, k) is likely to produce owerflow if one tries +C to solve for x in Ax = b. So U is perturbed to get +C a nonsingular system. This is a warning. +C +C FURTHER COMMENTS +C +C In the interests of speed, this routine does not check the input +C for errors. It should only be used to factorize matrices A of +C very small order. +C +C CONTRIBUTOR +C +C Bo Kagstrom and Peter Poromaa, Univ. of Umea, Sweden, Nov. 1993. +C +C REVISIONS +C +C April 1998 (T. Penzl). +C Sep. 1998 (V. Sima). +C March 1999 (V. Sima). +C March 2004 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, N +C .. Array Arguments .. + INTEGER IPIV( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ) +C .. Local Scalars .. + INTEGER I, IP, IPV, JP, JPV + DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL DGER, DLABAD, DSCAL, DSWAP +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. +C +C Set constants to control owerflow. + + INFO = 0 + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) / EPS + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Find max element in matrix A. +C + IPV = 1 + JPV = 1 + XMAX = ZERO + DO 40 JP = 1, N + DO 20 IP = 1, N + IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN + XMAX = ABS( A(IP, JP) ) + IPV = IP + JPV = JP + ENDIF + 20 CONTINUE + 40 CONTINUE + SMIN = MAX( EPS * XMAX, SMLNUM ) +C +C Swap rows. +C + IF ( IPV .NE. 1 ) CALL DSWAP( N, A(IPV, 1), LDA, A(1, 1), LDA ) + IPIV(1) = IPV +C +C Swap columns. +C + IF ( JPV .NE. 1 ) CALL DSWAP( N, A(1, JPV), 1, A(1, 1), 1 ) + JPIV(1) = JPV +C +C Check for singularity. +C + IF ( ABS( A(1, 1) ) .LT. SMIN ) THEN + INFO = 1 + A(1, 1) = SMIN + ENDIF + IF ( N.GT.1 ) THEN + CALL DSCAL( N - 1, ONE / A(1, 1), A(2, 1), 1 ) + CALL DGER( N - 1, N - 1, -ONE, A(2, 1), 1, A(1, 2), LDA, + $ A(2, 2), LDA ) + ENDIF +C +C Factorize the rest of A with complete pivoting. +C Set pivots less than SMIN to SMIN. +C + DO 100 I = 2, N - 1 +C +C Find max element in remaining matrix. +C + IPV = I + JPV = I + XMAX = ZERO + DO 80 JP = I, N + DO 60 IP = I, N + IF ( ABS( A(IP, JP) ) .GT. XMAX ) THEN + XMAX = ABS( A(IP, JP) ) + IPV = IP + JPV = JP + ENDIF + 60 CONTINUE + 80 CONTINUE +C +C Swap rows. +C + IF ( IPV .NE. I ) CALL DSWAP( N, A(IPV, 1), LDA, A(I, 1), LDA ) + IPIV(I) = IPV +C +C Swap columns. +C + IF ( JPV .NE. I ) CALL DSWAP( N, A(1, JPV), 1, A(1, I), 1 ) + JPIV(I) = JPV +C +C Check for almost singularity. +C + IF ( ABS( A(I, I) ) .LT. SMIN ) THEN + INFO = I + A(I, I) = SMIN + ENDIF + CALL DSCAL( N - I, ONE / A(I, I), A(I + 1, I), 1 ) + CALL DGER( N - I, N - I, -ONE, A(I + 1, I), 1, A(I, I + 1), + $ LDA, A(I + 1, I + 1), LDA ) + 100 CONTINUE + IF ( ABS( A(N, N) ) .LT. SMIN ) THEN + INFO = N + A(N, N) = SMIN + ENDIF +C + RETURN +C *** Last line of MB02UV *** + END diff --git a/mex/sources/libslicot/MB02VD.f b/mex/sources/libslicot/MB02VD.f new file mode 100644 index 000000000..5896d2349 --- /dev/null +++ b/mex/sources/libslicot/MB02VD.f @@ -0,0 +1,187 @@ + SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/MB02WD.f b/mex/sources/libslicot/MB02WD.f new file mode 100644 index 000000000..59816e037 --- /dev/null +++ b/mex/sources/libslicot/MB02WD.f @@ -0,0 +1,458 @@ + SUBROUTINE MB02WD( FORM, F, N, IPAR, LIPAR, DPAR, LDPAR, ITMAX, + $ A, LDA, B, INCB, X, INCX, TOL, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the system of linear equations Ax = b, with A symmetric, +C positive definite, or, in the implicit form, f(A, x) = b, where +C y = f(A, x) is a symmetric positive definite linear mapping +C from x to y, using the conjugate gradient (CG) algorithm without +C preconditioning. +C +C ARGUMENTS +C +C Mode Parameters +C +C FORM CHARACTER*1 +C Specifies the form of the system of equations, as +C follows: +C = 'U' : Ax = b, the upper triagular part of A is used; +C = 'L' : Ax = b, the lower triagular part of A is used; +C = 'F' : the implicit, function form, f(A, x) = b. +C +C Function Parameters +C +C F EXTERNAL +C If FORM = 'F', then F is a subroutine which calculates the +C value of f(A, x), for given A and x. +C If FORM <> 'F', then F is not called. +C +C F must have the following interface: +C +C SUBROUTINE F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, X, +C $ INCX, DWORK, LDWORK, INFO ) +C +C where +C +C N (input) INTEGER +C The dimension of the vector x. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the matrix A. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the +C problem. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 0. +C +C A (input) DOUBLE PRECISION array, dimension +C (LDA, NC), where NC is the number of columns. +C The leading NR-by-NC part of this array must +C contain the (compressed) representation of the +C matrix A, where NR is the number of rows of A +C (function of IPAR entries). +C +C LDA (input) INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,NR). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, this incremented array must contain the +C vector x. +C On exit, this incremented array contains the value +C of the function f, y = f(A, x). +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX > 0. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine F. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine F). +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input scalar argument is erroneous, and to +C positive values for other possible errors in the +C subroutine F. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO. +C INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the vector x. N >= 0. +C If FORM = 'U' or FORM = 'L', N is also the number of rows +C and columns of the matrix A. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C If FORM = 'F', the integer parameters describing the +C structure of the matrix A. +C This parameter is ignored if FORM = 'U' or FORM = 'L'. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C If FORM = 'F', the real parameters needed for solving +C the problem. +C This parameter is ignored if FORM = 'U' or FORM = 'L'. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 0. +C +C ITMAX (input) INTEGER +C The maximal number of iterations to do. ITMAX >= 0. +C +C A (input) DOUBLE PRECISION array, +C dimension (LDA, NC), if FORM = 'F', +C dimension (LDA, N), otherwise. +C If FORM = 'F', the leading NR-by-NC part of this array +C must contain the (compressed) representation of the +C matrix A, where NR and NC are the number of rows and +C columns, respectively, of the matrix A. The array A is +C not referenced by this routine itself, except in the +C calls to the routine F. +C If FORM <> 'F', the leading N-by-N part of this array +C must contain the matrix A, assumed to be symmetric; +C only the triangular part specified by FORM is referenced. +C +C LDA (input) INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,NR), if FORM = 'F'; +C LDA >= MAX(1,N), if FORM = 'U' or FORM = 'L'. +C +C B (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCB) +C The incremented vector b. +C +C INCB (input) INTEGER +C The increment for the elements of B. INCB > 0. +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, this incremented array must contain an initial +C approximation of the solution. If an approximation is not +C known, setting all elements of x to zero is recommended. +C On exit, this incremented array contains the computed +C solution x of the system of linear equations. +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX > 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If TOL > 0, absolute tolerance for the iterative process. +C The algorithm will stop if || Ax - b ||_2 <= TOL. Since +C it is advisable to use a relative tolerance, say TOLER, +C TOL should be chosen as TOLER*|| b ||_2. +C If TOL <= 0, a default relative tolerance, +C TOLDEF = N*EPS*|| b ||_2, is used, where EPS is the +C machine precision (see LAPACK Library routine DLAMCH). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the number of +C iterations performed and DWORK(2) returns the remaining +C residual, || Ax - b ||_2. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(2,3*N + DWORK(F)), if FORM = 'F', +C where DWORK(F) is the workspace needed by F; +C LDWORK >= MAX(2,3*N), if FORM = 'U' or FORM = 'L'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the algorithm finished after ITMAX > 0 iterations, +C without achieving the desired precision TOL; +C = 2: ITMAX is zero; in this case, DWORK(2) is not set. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then F returned with INFO = i. +C +C METHOD +C +C The following CG iteration is used for solving Ax = b: +C +C Start: q(0) = r(0) = Ax - b +C +C < q(k), r(k) > +C ALPHA(k) = - ---------------- +C < q(k), Aq(k) > +C x(k+1) = x(k) - ALPHA(k) * q(k) +C r(k+1) = r(k) - ALPHA(k) * Aq(k) +C < r(k+1), r(k+1) > +C BETA(k) = -------------------- +C < r(k) , r(k) > +C q(k+1) = r(k+1) + BETA(k) * q(k) +C +C where <.,.> denotes the scalar product. +C +C REFERENCES +C +C [1] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, +C 1996. +C +C [2] Luenberger, G. +C Introduction to Linear and Nonlinear Programming. +C Addison-Wesley, Reading, MA, p.187, York, 1973. +C +C NUMERICAL ASPECTS +C +C Since the residuals are orthogonal in the scalar product +C = y'Ax, the algorithm is theoretically finite. But rounding +C errors cause a loss of orthogonality, so a finite termination +C cannot be guaranteed. However, one can prove [2] that +C +C || x-x_k ||_A := sqrt( (x-x_k)' * A * (x-x_k) ) +C +C sqrt( kappa_2(A) ) - 1 +C <= 2 || x-x_0 ||_A * ------------------------ , +C sqrt( kappa_2(A) ) + 1 +C +C where kappa_2 is the condition number. +C +C The approximate number of floating point operations is +C (k*(N**2 + 15*N) + N**2 + 3*N)/2, if FORM <> 'F', +C k*(f + 7*N) + f, if FORM = 'F', +C where k is the number of CG iterations performed, and f is the +C number of floating point operations required by the subroutine F. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C March, 2002. +C +C KEYWORDS +C +C Conjugate gradients, convergence, linear system of equations, +C matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FORM + INTEGER INCB, INCX, INFO, ITMAX, IWARN, LDA, LDPAR, + $ LDWORK, LIPAR, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), DPAR(*), DWORK(*), X(*) + INTEGER IPAR(*) +C .. Local Scalars .. + DOUBLE PRECISION ALPHA, BETA, RES, RESOLD, TOLDEF + INTEGER AQ, DWLEFT, K, R + LOGICAL MAT +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, DSYMV, F, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MAT = LSAME( FORM, 'U' ) .OR. LSAME( FORM, 'L' ) +C +C Check the scalar input parameters. +C + IWARN = 0 + INFO = 0 + IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN + INFO = -1 + ELSEIF ( N.LT.0 ) THEN + INFO = -3 + ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN + INFO = -5 + ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN + INFO = -7 + ELSEIF ( ITMAX.LT.0 ) THEN + INFO = -8 + ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.N ) ) THEN + INFO = -10 + ELSEIF ( INCB.LE.0 ) THEN + INFO = -12 + ELSEIF ( INCX.LE.0 ) THEN + INFO = -14 + ELSEIF ( LDWORK.LT.MAX( 2, 3*N ) ) THEN + INFO = -17 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02WD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ZERO + DWORK(2) = ZERO + RETURN + ENDIF +C + IF ( ITMAX.EQ.0 ) THEN + DWORK(1) = ZERO + IWARN = 2 + RETURN + ENDIF +C +C Set default tolerance, if needed. +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )*DNRM2( N, B, INCB ) +C +C Initialize local variables. +C + K = 0 +C +C Vector q is stored in DWORK(1), A*q or f(A, q) in DWORK(AQ), +C and r in DWORK(R). The workspace for F starts in DWORK(DWLEFT). +C + AQ = N + 1 + R = N + AQ + DWLEFT = N + R +C +C Prepare the first iteration, initialize r and q. +C + IF ( MAT ) THEN + CALL DCOPY( N, B, INCB, DWORK(R), 1 ) + CALL DSYMV( FORM, N, ONE, A, LDA, X, INCX, -ONE, DWORK(R), 1 ) + ELSE + CALL DCOPY( N, X, INCX, DWORK(R), 1 ) + CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(R), 1, + $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + CALL DAXPY( N, -ONE, B, INCB, DWORK(R), 1 ) + ENDIF + CALL DCOPY( N, DWORK(R), 1, DWORK, 1 ) +C + RES = DNRM2( N, DWORK(R), 1 ) +C +C Do nothing if x is already the solution. +C + IF ( RES.LE.TOLDEF ) GOTO 20 +C +C Begin of the iteration loop. +C +C WHILE ( RES.GT.TOLDEF .AND. K.LE.ITMAX ) DO + 10 CONTINUE +C +C Calculate A*q or f(A, q). +C + IF ( MAT ) THEN + CALL DSYMV( FORM, N, ONE, A, LDA, DWORK, 1, ZERO, DWORK(AQ), + $ 1 ) + ELSE + CALL DCOPY( N, DWORK, 1, DWORK(AQ), 1 ) + CALL F( N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, DWORK(AQ), 1, + $ DWORK(DWLEFT), LDWORK-DWLEFT+1, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + ENDIF +C +C Calculate ALPHA(k). +C + ALPHA = DDOT( N, DWORK, 1, DWORK(R), 1 ) / + $ DDOT( N, DWORK, 1, DWORK(AQ), 1 ) +C +C x(k+1) = x(k) - ALPHA(k)*q(k). +C + CALL DAXPY( N, -ALPHA, DWORK, 1, X, INCX ) +C +C r(k+1) = r(k) - ALPHA(k)*(A*q(k)). +C + CALL DAXPY( N, -ALPHA, DWORK(AQ), 1, DWORK(R), 1 ) +C +C Save RES and calculate a new RES. +C + RESOLD = RES + RES = DNRM2( N, DWORK(R), 1 ) +C +C Exit if tolerance is reached. +C + IF ( RES.LE.TOLDEF ) GOTO 20 +C +C Calculate BETA(k). +C + BETA = ( RES/RESOLD )**2 +C +C q(k+1) = r(k+1) + BETA(k)*q(k). +C + CALL DSCAL( N, BETA, DWORK, 1 ) + CALL DAXPY( N, ONE, DWORK(R), 1, DWORK, 1 ) +C +C End of the iteration loop. +C + K = K + 1 + IF ( K.LT.ITMAX ) GOTO 10 +C END WHILE 10 +C +C Tolerance was not reached! +C + IWARN = 1 +C + 20 CONTINUE +C + DWORK(1) = K + DWORK(2) = RES +C +C *** Last line of MB02WD *** + END diff --git a/mex/sources/libslicot/MB02XD.f b/mex/sources/libslicot/MB02XD.f new file mode 100644 index 000000000..0575a907a --- /dev/null +++ b/mex/sources/libslicot/MB02XD.f @@ -0,0 +1,409 @@ + SUBROUTINE MB02XD( FORM, STOR, UPLO, F, M, N, NRHS, IPAR, LIPAR, + $ DPAR, LDPAR, A, LDA, B, LDB, ATA, LDATA, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a set of systems of linear equations, A'*A*X = B, or, +C in the implicit form, f(A)*X = B, with A'*A or f(A) positive +C definite, using symmetric Gaussian elimination. +C +C ARGUMENTS +C +C Mode Parameters +C +C FORM CHARACTER*1 +C Specifies the form in which the matrix A is provided, as +C follows: +C = 'S' : standard form, the matrix A is given; +C = 'F' : the implicit, function form f(A) is provided. +C If FORM = 'F', then the routine F is called to compute the +C matrix A'*A. +C +C STOR CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix A'*A, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix A'*A is stored, as +C follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C Function Parameters +C +C F EXTERNAL +C If FORM = 'F', then F is a subroutine which calculates the +C value of f(A) = A'*A, for given A. +C If FORM = 'S', then F is not called. +C +C F must have the following interface: +C +C SUBROUTINE F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, +C $ LDA, ATA, LDATA, DWORK, LDWORK, INFO ) +C +C where +C +C STOR (input) CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix A'*A, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO (input) CHARACTER*1 +C Specifies which part of the matrix A'*A is stored, +C as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C N (input) INTEGER +C The order of the matrix A'*A. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the matrix A. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the +C problem. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 0. +C +C A (input) DOUBLE PRECISION array, dimension +C (LDA, NC), where NC is the number of columns. +C The leading NR-by-NC part of this array must +C contain the (compressed) representation of the +C matrix A, where NR is the number of rows of A +C (function of IPAR entries). +C +C LDA (input) INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,NR). +C +C ATA (output) DOUBLE PRECISION array, +C dimension (LDATA,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 +C (if STOR = 'P') part of this array contains the +C upper or lower triangle of the matrix A'*A, +C depending on UPLO = 'U', or UPLO = 'L', +C respectively, stored either as a two-dimensional, +C or one-dimensional array, depending on STOR. +C +C LDATA (input) INTEGER +C The leading dimension of the array ATA. +C LDATA >= MAX(1,N), if STOR = 'F'. +C LDATA >= 1, if STOR = 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine F. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine F). +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input scalar argument is erroneous, and to +C positive values for other possible errors in the +C subroutine F. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO. +C INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The order of the matrix A'*A, the number of columns of the +C matrix A, and the number of rows of the matrix X. N >= 0. +C +C NRHS (input) INTEGER +C The number of columns of the matrices B and X. NRHS >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C If FORM = 'F', the integer parameters describing the +C structure of the matrix A. +C This parameter is ignored if FORM = 'S'. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C If FORM = 'F', the real parameters needed for solving +C the problem. +C This parameter is ignored if FORM = 'S'. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 0. +C +C A (input) DOUBLE PRECISION array, +C dimension (LDA, N), if FORM = 'S', +C dimension (LDA, NC), if FORM = 'F', where NC is +C the number of columns. +C If FORM = 'S', the leading M-by-N part of this array +C must contain the matrix A. +C If FORM = 'F', the leading NR-by-NC part of this array +C must contain an appropriate representation of matrix A, +C where NR is the number of rows. +C If FORM = 'F', this array is not referenced by this +C routine itself, except in the call to the routine F. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,M), if FORM = 'S'; +C LDA >= MAX(1,NR), if FORM = 'F'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB, NRHS) +C On entry, the leading N-by-NRHS part of this array must +C contain the right hand side matrix B. +C On exit, if INFO = 0 and M (or NR) is nonzero, the leading +C N-by-NRHS part of this array contains the solution X of +C the set of systems of linear equations A'*A*X = B or +C f(A)*X = B. If M (or NR) is zero, then B is unchanged. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C ATA (output) DOUBLE PRECISION array, +C dimension (LDATA,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if +C STOR = 'P') part of this array contains the upper or lower +C triangular Cholesky factor of the matrix A'*A, depending +C on UPLO = 'U', or UPLO = 'L', respectively, stored either +C as a two-dimensional, or one-dimensional array, depending +C on STOR. +C +C LDATA INTEGER +C The leading dimension of the array ATA. +C LDATA >= MAX(1,N), if STOR = 'F'. +C LDATA >= 1, if STOR = 'P'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then the (i,i) element of the +C triangular factor of the matrix A'*A is exactly +C zero (the matrix A'*A is exactly singular); +C if INFO = j > n, then F returned with INFO = j-n. +C +C METHOD +C +C The matrix A'*A is built either directly (if FORM = 'S'), or +C implicitly, by calling the routine F. Then, A'*A is Cholesky +C factored and its factor is used to solve the set of systems of +C linear equations, A'*A*X = B. +C +C REFERENCES +C +C [1] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, 1996. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Blackford, Demmel, J., +C Dongarra, J., Du Croz, J., Greenbaum, A., Hammarling, S., +C McKenney, A., Sorensen, D. +C LAPACK Users' Guide: Third Edition, SIAM, Philadelphia, 1999. +C +C NUMERICAL ASPECTS +C +C For speed, this routine does not check for near singularity of the +C matrix A'*A. If the matrix A is nearly rank deficient, then the +C computed X could be inaccurate. Estimates of the reciprocal +C condition numbers of the matrices A and A'*A can be obtained +C using LAPACK routines DGECON and DPOCON (DPPCON), respectively. +C +C The approximate number of floating point operations is +C (M+3)*N**2/2 + N**3/6 + NRHS*N**2, if FORM = 'S', +C f + N**3/6 + NRHS*N**2, if FORM = 'F', +C where M is the number of rows of A, and f is the number of +C floating point operations required by the subroutine F. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C V. Sima, Mar. 2002. +C +C KEYWORDS +C +C Linear system of equations, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FORM, STOR, UPLO + INTEGER INFO, LDA, LDATA, LDB, LDPAR, LDWORK, LIPAR, M, + $ N, NRHS +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ATA(*), B(LDB,*), DPAR(*), DWORK(*) + INTEGER IPAR(*) +C .. Local Scalars .. + INTEGER IERR, J, J1 + LOGICAL FULL, MAT, UPPER +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMV, DPOTRF, DPOTRS, DPPTRF, DPPTRS, DSYRK, F, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + MAT = LSAME( FORM, 'S' ) + FULL = LSAME( STOR, 'F' ) + UPPER = LSAME( UPLO, 'U' ) +C +C Check the scalar input parameters. +C + INFO = 0 + IF( .NOT.( MAT .OR. LSAME( FORM, 'F' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -2 + ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -3 + ELSEIF ( M.LT.0 ) THEN + INFO = -5 + ELSEIF ( N.LT.0 ) THEN + INFO = -6 + ELSEIF ( NRHS.LT.0 ) THEN + INFO = -7 + ELSEIF ( .NOT. MAT .AND. LIPAR.LT.0 ) THEN + INFO = -9 + ELSEIF ( .NOT. MAT .AND. LDPAR.LT.0 ) THEN + INFO = -11 + ELSEIF ( LDA.LT.1 .OR. ( MAT .AND. LDA.LT.M ) ) THEN + INFO = -13 + ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSEIF ( LDATA.LT.1 .OR. ( FULL .AND. LDATA.LT.N ) ) THEN + INFO = -17 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02XD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. ( MAT .AND. M.EQ.0 ) ) + $ RETURN +C +C Build a triangle of the matrix A'*A. +C + IF ( MAT ) THEN +C +C Matrix A is given in the usual form. +C + IF ( FULL ) THEN + CALL DSYRK( UPLO, 'Transpose', N, M, ONE, A, LDA, ZERO, + $ ATA, LDATA ) + ELSEIF ( UPPER ) THEN + J1 = 1 +C + DO 10 J = 1, N + CALL DGEMV( 'Transpose', M, J, ONE, A, LDA, A(1,J), 1, + $ ZERO, ATA(J1), 1 ) + J1 = J1 + J + 10 CONTINUE +C + ELSE + J1 = 1 +C + DO 20 J = 1, N + CALL DGEMV( 'Transpose', M, N-J+1, ONE, A(1,J), LDA, + $ A(1,J), 1, ZERO, ATA(J1), 1 ) + J1 = J1 + N - J + 1 + 20 CONTINUE +C + ENDIF +C + ELSE +C +C Implicit form, A'*A = f(A). +C + CALL F( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, A, LDA, ATA, + $ LDATA, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = N + IERR + RETURN + ENDIF +C + ENDIF +C +C Factor the matrix A'*A. +C + IF ( FULL ) THEN + CALL DPOTRF( UPLO, N, ATA, LDATA, IERR ) + ELSE + CALL DPPTRF( UPLO, N, ATA, IERR ) + ENDIF +C + IF ( IERR.NE.0 ) THEN + INFO = IERR + RETURN + ENDIF +C +C Solve the set of linear systems. +C + IF ( FULL ) THEN + CALL DPOTRS( UPLO, N, NRHS, ATA, LDATA, B, LDB, IERR ) + ELSE + CALL DPPTRS( UPLO, N, NRHS, ATA, B, LDB, IERR ) + ENDIF +C +C *** Last line of MB02XD *** + END diff --git a/mex/sources/libslicot/MB02YD.f b/mex/sources/libslicot/MB02YD.f new file mode 100644 index 000000000..981af1f03 --- /dev/null +++ b/mex/sources/libslicot/MB02YD.f @@ -0,0 +1,371 @@ + SUBROUTINE MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANK, X, TOL, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a vector x which solves the system of linear +C equations +C +C A*x = b , D*x = 0 , +C +C in the least squares sense, where A is an m-by-n matrix, +C D is an n-by-n diagonal matrix, and b is an m-vector. +C It is assumed that a QR factorization, with column pivoting, of A +C is available, that is, A*P = Q*R, where P is a permutation matrix, +C Q has orthogonal columns, and R is an upper triangular matrix +C with diagonal elements of nonincreasing magnitude. +C The routine needs the full upper triangle of R, the permutation +C matrix P, and the first n components of Q'*b (' denotes the +C transpose). The system A*x = b, D*x = 0, is then equivalent to +C +C R*z = Q'*b , P'*D*P*z = 0 , (1) +C +C where x = P*z. If this system does not have full rank, then a +C least squares solution is obtained. On output, MB02YD also +C provides an upper triangular matrix S such that +C +C P'*(A'*A + D*D)*P = S'*S . +C +C The system (1) is equivalent to S*z = c , where c contains the +C first n components of the vector obtained by applying to +C [ (Q'*b)' 0 ]' the transformations which triangularized +C [ R' P'*D*P ]', getting S. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the matrix S should be +C estimated, as follows: +C = 'E' : use incremental condition estimation and store +C the numerical rank of S in RANK; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of S for zero values; +C = 'U' : use the rank already stored in RANK. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the full upper triangle is unaltered, and the +C strict lower triangle contains the strict upper triangle +C (transposed) of the upper triangular matrix S. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C A*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C RANK (input or output) INTEGER +C On entry, if COND = 'U', this parameter must contain the +C (numerical) rank of the matrix S. +C On exit, if COND = 'E' or 'N', this parameter contains +C the numerical rank of the matrix S, estimated according +C to the value of COND. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system A*x = b, D*x = 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C rank of the matrix S. If the user sets TOL > 0, then the +C given value of TOL is used as a lower bound for the +C reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S, and +C the next N elements contain the solution z. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 4*N, if COND = 'E'; +C LDWORK >= 2*N, if COND <> 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Standard plane rotations are used to annihilate the elements of +C the diagonal matrix D, updating the upper triangular matrix R +C and the first n elements of the vector Q'*b. A basic least squares +C solution is computed. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C This routine is a LAPACK-based modification of QRSOLV from the +C MINPACK package [1], and with optional condition estimation. +C The option COND = 'U' is useful when dealing with several +C right-hand side vectors. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, SVLMAX + PARAMETER ( ZERO = 0.0D0, SVLMAX = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, N, RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IPVT(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) +C .. Local Scalars .. + DOUBLE PRECISION CS, QTBPJ, SN, TEMP, TOLDEF + INTEGER I, J, K, L + LOGICAL ECOND, NCOND, UCOND +C .. Local Arrays .. + DOUBLE PRECISION DUM(3) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DROT, DSWAP, MB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + NCOND = LSAME( COND, 'N' ) + UCOND = LSAME( COND, 'U' ) + INFO = 0 + IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN + INFO = -1 + ELSEIF( N.LT.0 ) THEN + INFO = -2 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN + INFO = -8 + ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN + INFO = -12 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB02YD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( .NOT.UCOND ) + $ RANK = 0 + RETURN + END IF +C +C Copy R and Q'*b to preserve input and initialize S. +C In particular, save the diagonal elements of R in X. +C + DO 20 J = 1, N + X(J) = R(J,J) + DO 10 I = J, N + R(I,J) = R(J,I) + 10 CONTINUE + 20 CONTINUE +C + CALL DCOPY( N, QTB, 1, DWORK(N+1), 1 ) +C +C Eliminate the diagonal matrix D using Givens rotations. +C + DO 50 J = 1, N +C +C Prepare the row of D to be eliminated, locating the +C diagonal element using P from the QR factorization. +C + L = IPVT(J) + IF ( DIAG(L).NE.ZERO ) THEN + QTBPJ = ZERO + DWORK(J) = DIAG(L) +C + DO 30 K = J + 1, N + DWORK(K) = ZERO + 30 CONTINUE +C +C The transformations to eliminate the row of D modify only +C a single element of Q'*b beyond the first n, which is +C initially zero. +C + DO 40 K = J, N +C +C Determine a Givens rotation which eliminates the +C appropriate element in the current row of D. +C + IF ( DWORK(K).NE.ZERO ) THEN +C + CALL DLARTG( R(K,K), DWORK(K), CS, SN, TEMP ) +C +C Compute the modified diagonal element of R and +C the modified elements of (Q'*b,0). +C Accumulate the tranformation in the row of S. +C + TEMP = CS*DWORK(N+K) + SN*QTBPJ + QTBPJ = -SN*DWORK(N+K) + CS*QTBPJ + DWORK(N+K) = TEMP + CALL DROT( N-K+1, R(K,K), 1, DWORK(K), 1, CS, SN ) +C + END IF + 40 CONTINUE +C + END IF +C +C Store the diagonal element of S and, if COND <> 'E', restore +C the corresponding diagonal element of R. +C + DWORK(J) = R(J,J) + IF ( .NOT.ECOND ) + $ R(J,J) = X(J) + 50 CONTINUE +C +C Solve the triangular system for z. If the system is singular, +C then obtain a least squares solution. +C + IF ( ECOND ) THEN + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + END IF +C +C Interchange the strict upper and lower triangular parts of R. +C + DO 60 J = 2, N + CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) + 60 CONTINUE +C +C Estimate the reciprocal condition number of S and set the rank. +C Additional workspace: 2*N. +C + CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TOLDEF, SVLMAX, + $ DWORK, RANK, DUM, DWORK(2*N+1), LDWORK-2*N, + $ INFO ) + R(1,1) = X(1) +C +C Restore the strict upper and lower triangular parts of R. +C + DO 70 J = 2, N + CALL DSWAP( J-1, R(1,J), 1, R(J,1), LDR ) + R(J,J) = X(J) + 70 CONTINUE +C + ELSEIF ( NCOND ) THEN +C +C Determine rank(S) by checking zero diagonal entries. +C + RANK = N +C + DO 80 J = 1, N + IF ( DWORK(J).EQ.ZERO .AND. RANK.EQ.N ) + $ RANK = J - 1 + 80 CONTINUE +C + END IF +C + DUM(1) = ZERO + IF ( RANK.LT.N ) + $ CALL DCOPY( N-RANK, DUM, 0, DWORK(N+RANK+1), 1 ) +C +C Solve S*z = c using back substitution. +C + DO 100 J = RANK, 1, -1 + TEMP = ZERO +C + DO 90 I = J + 1, RANK + TEMP = TEMP + R(I,J)*DWORK(N+I) + 90 CONTINUE +C + DWORK(N+J) = ( DWORK(N+J) - TEMP )/DWORK(J) + 100 CONTINUE +C +C Permute the components of z back to components of x. +C + DO 110 J = 1, N + L = IPVT(J) + X(L) = DWORK(N+J) + 110 CONTINUE +C + RETURN +C +C *** Last line of MB02YD *** + END diff --git a/mex/sources/libslicot/MB03MD.f b/mex/sources/libslicot/MB03MD.f new file mode 100644 index 000000000..7f47657fd --- /dev/null +++ b/mex/sources/libslicot/MB03MD.f @@ -0,0 +1,343 @@ + SUBROUTINE MB03MD( N, L, THETA, Q, E, Q2, E2, PIVMIN, TOL, RELTOL, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an upper bound THETA using a bisection method such that +C the bidiagonal matrix +C +C |q(1) e(1) 0 ... 0 | +C | 0 q(2) e(2) . | +C J = | . . | +C | . e(N-1)| +C | 0 ... ... q(N) | +C +C has precisely L singular values less than or equal to THETA plus +C a given tolerance TOL. +C +C This routine is mainly intended to be called only by other SLICOT +C routines. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the bidiagonal matrix J. N >= 0. +C +C L (input/output) INTEGER +C On entry, L must contain the number of singular values +C of J which must be less than or equal to the upper bound +C computed by the routine. 0 <= L <= N. +C On exit, L may be increased if the L-th smallest singular +C value of J has multiplicity greater than 1. In this case, +C L is increased by the number of singular values of J which +C are larger than its L-th smallest one and approach the +C L-th smallest singular value of J within a distance less +C than TOL. +C If L has been increased, then the routine returns with +C IWARN set to 1. +C +C THETA (input/output) DOUBLE PRECISION +C On entry, THETA must contain an initial estimate for the +C upper bound to be computed. If THETA < 0.0 on entry, then +C one of the following default values is used. +C If L = 0, THETA is set to 0.0 irrespective of the input +C value of THETA; if L = 1, then THETA is taken as +C MIN(ABS(Q(i))), for i = 1,2,...,N; otherwise, THETA is +C taken as ABS(Q(N-L+1)). +C On exit, THETA contains the computed upper bound such that +C the bidiagonal matrix J has precisely L singular values +C less than or equal to THETA + TOL. +C +C Q (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements q(1), +C q(2),...,q(N) of the bidiagonal matrix J. That is, +C Q(i) = J(i,i) for i = 1,2,...,N. +C +C E (input) DOUBLE PRECISION array, dimension (N-1) +C This array must contain the superdiagonal elements +C e(1),e(2),...,e(N-1) of the bidiagonal matrix J. That is, +C E(k) = J(k,k+1) for k = 1,2,...,N-1. +C +C Q2 (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the squares of the diagonal +C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. +C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. +C +C E2 (input) DOUBLE PRECISION array, dimension (N-1) +C This array must contain the squares of the superdiagonal +C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. +C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. +C +C PIVMIN (input) DOUBLE PRECISION +C The minimum absolute value of a "pivot" in the Sturm +C sequence loop. +C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), +C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at +C least the smallest number that can divide one without +C overflow (see LAPACK Library routine DLAMCH). +C Note that this condition is not checked by the routine. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C This parameter defines the multiplicity of singular values +C by considering all singular values within an interval of +C length TOL as coinciding. TOL is used in checking how many +C singular values are less than or equal to THETA. Also in +C computing an appropriate upper bound THETA by a bisection +C method, TOL is used as a stopping criterion defining the +C minimum (absolute) subinterval width. TOL >= 0. +C +C RELTOL DOUBLE PRECISION +C This parameter specifies the minimum relative width of an +C interval. When an interval is narrower than TOL, or than +C RELTOL times the larger (in magnitude) endpoint, then it +C is considered to be sufficiently small and bisection has +C converged. +C RELTOL >= BASE * EPS, where BASE is machine radix and EPS +C is machine precision (see LAPACK Library routine DLAMCH). +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warnings; +C = 1: if the value of L has been increased as the L-th +C smallest singular value of J coincides with the +C (L+1)-th smallest one. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let s(i), i = 1,2,...,N, be the N non-negative singular values of +C the bidiagonal matrix J arranged so that s(1) >= ... >= s(N) >= 0. +C The routine then computes an upper bound T such that s(N-L) > T >= +C s(N-L+1) as follows (see [2]). +C First, if the initial estimate of THETA is not specified by the +C user then the routine initialises THETA to be an estimate which +C is close to the requested value of THETA if s(N-L) >> s(N-L+1). +C Second, a bisection method (see [1, 8.5]) is used which generates +C a sequence of shrinking intervals [Y,Z] such that either THETA in +C [Y,Z] was found (so that J has L singular values less than or +C equal to THETA), or +C +C (number of s(i) <= Y) < L < (number of s(i) <= Z). +C +C This bisection method is applied to an associated 2N-by-2N +C symmetric tridiagonal matrix T" whose eigenvalues (see [1]) are +C given by s(1),s(2),...,s(N),-s(1),-s(2),...,-s(N). One of the +C starting values for the bisection method is the initial value of +C THETA. If this value is an upper bound, then the initial lower +C bound is set to zero, else the initial upper bound is computed +C from the Gershgorin Circle Theorem [1, Theorem 7.2-1], applied to +C T". The computation of the "number of s(i) <= Y (or Z)" is +C achieved by calling SLICOT Library routine MB03ND, which applies +C Sylvester's Law of Inertia or equivalently Sturm sequences +C [1, 8.5] to the associated matrix T". If +C +C Z - Y <= MAX( TOL, PIVMIN, RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) +C +C at some stage of the bisection method, then at least two singular +C values of J lie in the interval [Y,Z] within a distance less than +C TOL from each other. In this case, s(N-L) and s(N-L+1) are assumed +C to coincide, the upper bound T is set to the value of Z, the value +C of L is increased and IWARN is set to 1. +C +C REFERENCES +C +C [1] Golub, G.H. and Van Loan, C.F. +C Matrix Computations. +C The Johns Hopkins University Press, Baltimore, Maryland, 1983. +C +C [2] Van Huffel, S. and Vandewalle, J. +C The Partial Total Least Squares Algorithm. +C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB03AD by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C June 16, 1997, Oct. 26, 2003. +C +C KEYWORDS +C +C Bidiagonal matrix, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, TWO + PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0 ) + DOUBLE PRECISION FUDGE + PARAMETER ( FUDGE = TWO ) +C .. Scalar Arguments .. + INTEGER INFO, IWARN, L, N + DOUBLE PRECISION PIVMIN, RELTOL, THETA, TOL +C .. Array Arguments .. + DOUBLE PRECISION E(*), E2(*), Q(*), Q2(*) +C .. Local Scalars .. + INTEGER I, NUM, NUMZ + DOUBLE PRECISION H, TH, Y, Z +C .. External Functions .. + INTEGER MB03ND + DOUBLE PRECISION DLAMCH, MB03MY + EXTERNAL DLAMCH, MB03MY, MB03ND +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C +C Test some input scalar arguments. +C + IWARN = 0 + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( L.LT.0 .OR. L.GT.N ) THEN + INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C +C Step 1: initialisation of THETA. +C ----------------------- + IF ( L.EQ.0 ) THETA = ZERO + IF ( THETA.LT.ZERO ) THEN + IF ( L.EQ.1 ) THEN +C +C An upper bound which is close if S(N-1) >> S(N): +C + THETA = MB03MY( N, Q, 1 ) + IF ( N.EQ.1 ) + $ RETURN + ELSE +C +C An experimentally established estimate which is good if +C S(N-L) >> S(N-L+1): +C + THETA = ABS( Q(N-L+1) ) + END IF + END IF +C +C Step 2: Check quality of initial estimate THETA. +C --------------------------------------- + NUM = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) + IF ( NUM.EQ.L ) + $ RETURN +C +C Step 3: initialisation starting values for bisection method. +C --------------------------------------------------- +C Let S(i), i=1,...,N, be the singular values of J in decreasing +C order. Then, the computed Y and Z will be such that +C (number of S(i) <= Y) < L < (number of S(i) <= Z). +C + IF ( NUM.LT.L ) THEN + TH = ABS( Q(1) ) + Z = ZERO + Y = THETA + NUMZ = N +C + DO 20 I = 1, N - 1 + H = ABS( Q(I+1) ) + Z = MAX( MAX( TH, H ) + ABS( E(I) ), Z ) + TH = H + 20 CONTINUE +C +C Widen the Gershgorin interval a bit for machines with sloppy +C arithmetic. +C + Z = Z + FUDGE*ABS( Z )*DLAMCH( 'Epsilon' )*DBLE( N ) + $ + FUDGE*PIVMIN + ELSE + Z = THETA + Y = ZERO + NUMZ = NUM + END IF +C +C Step 4: Bisection method for finding the upper bound on the L +C smallest singular values of the bidiagonal. +C ------------------------------------------ +C A sequence of subintervals [Y,Z] is produced such that +C (number of S(i) <= Y) < L < (number of S(i) <= Z). +C NUM : number of S(i) <= TH, +C NUMZ: number of S(i) <= Z. +C +C WHILE ( ( NUM .NE. L ) .AND. +C ( ( Z-Y ) .GT. MAX( TOL, PIVMIN, RELTOL*ABS( Z ) ) ) ) DO + 40 IF ( ( NUM.NE.L ) .AND. + $ ( ABS( Z-Y ).GT.MAX( TOL, PIVMIN, + $ RELTOL*MAX( ABS( Y ), ABS( Z ) ) ) ) ) + $ THEN + TH = ( Y + Z )/TWO + NUM = MB03ND( N, TH, Q2, E2, PIVMIN, INFO ) + IF ( NUM.LT.L ) THEN + Y = TH + ELSE + Z = TH + NUMZ = NUM + END IF + GO TO 40 + END IF +C END WHILE 40 +C +C If NUM <> L and ( Z - Y ) <= TOL, then at least two singular +C values of J lie in the interval [Y,Z] within a distance less than +C TOL from each other. S(N-L) and S(N-L+1) are then assumed to +C coincide. L is increased, and a warning is given. +C + IF ( NUM.NE.L ) THEN + L = NUMZ + THETA = Z + IWARN = 1 + ELSE + THETA = TH + END IF +C + RETURN +C *** Last line of MB03MD *** + END diff --git a/mex/sources/libslicot/MB03MY.f b/mex/sources/libslicot/MB03MY.f new file mode 100644 index 000000000..cee355e8a --- /dev/null +++ b/mex/sources/libslicot/MB03MY.f @@ -0,0 +1,91 @@ + DOUBLE PRECISION FUNCTION MB03MY( NX, X, INCX ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the absolute minimal value of NX elements in an array. +C The function returns the value zero if NX < 1. +C +C ARGUMENTS +C +C NX (input) INTEGER +C The number of elements in X to be examined. +C +C X (input) DOUBLE PRECISION array, dimension (NX * INCX) +C The one-dimensional array of which the absolute minimal +C value of the elements is to be computed. +C This array is not referenced if NX < 1. +C +C INCX (input) INTEGER +C The increment to be taken in the array X, defining the +C distance between two consecutive elements. INCX >= 1. +C INCX = 1, if all elements are contiguous in memory. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MB03AZ by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C June 16, 1997. +C +C KEYWORDS +C +C None. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INCX, NX +C .. Array Arguments .. + DOUBLE PRECISION X(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION DX +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( NX.LE.0 ) THEN + MB03MY = ZERO + RETURN + END IF +C + MB03MY = ABS( X(1) ) +C + DO 20 I = 1+INCX, NX*INCX, INCX + DX = ABS( X(I) ) + IF ( DX.LT.MB03MY ) MB03MY = DX + 20 CONTINUE +C + RETURN +C *** Last line of MB03MY *** + END diff --git a/mex/sources/libslicot/MB03ND.f b/mex/sources/libslicot/MB03ND.f new file mode 100644 index 000000000..c681c2e53 --- /dev/null +++ b/mex/sources/libslicot/MB03ND.f @@ -0,0 +1,217 @@ + INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the number of singular values of the bidiagonal matrix +C +C |q(1) e(1) . ... 0 | +C | 0 q(2) e(2) . | +C J = | . . | +C | . e(N-1)| +C | 0 ... ... 0 q(N) | +C +C which are less than or equal to a given bound THETA. +C +C This routine is intended to be called only by other SLICOT +C routines. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the bidiagonal matrix J. N >= 0. +C +C THETA (input) DOUBLE PRECISION +C Given bound. +C Note: If THETA < 0.0 on entry, then MB03ND is set to 0 +C as the singular values of J are non-negative. +C +C Q2 (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the squares of the diagonal +C elements q(1),q(2),...,q(N) of the bidiagonal matrix J. +C That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N. +C +C E2 (input) DOUBLE PRECISION array, dimension (N-1) +C This array must contain the squares of the superdiagonal +C elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J. +C That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1. +C +C PIVMIN (input) DOUBLE PRECISION +C The minimum absolute value of a "pivot" in the Sturm +C sequence loop. +C PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ), +C where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at +C least the smallest number that can divide one without +C overflow (see LAPACK Library routine DLAMCH). +C Note that this condition is not checked by the routine. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The computation of the number of singular values s(i) of J which +C are less than or equal to THETA is based on applying Sylvester's +C Law of Inertia, or equivalently, Sturm sequences [1,p.52] to the +C unreduced symmetric tridiagonal matrices associated with J as +C follows. Let T be the following 2N-by-2N symmetric matrix +C associated with J: +C +C | 0 J'| +C T = | |. +C | J 0 | +C +C (The eigenvalues of T are given by s(1),s(2),...,s(N),-s(1),-s(2), +C ...,-s(N)). Then, by permuting the rows and columns of T into the +C order 1, N+1, 2, N+2, ..., N, 2N it follows that T is orthogonally +C similar to the tridiagonal matrix T" with zeros on its diagonal +C and q(1), e(1), q(2), e(2), ..., e(N-1), q(N) on its offdiagonals +C [3,4]. If q(1),q(2),...,q(N) and e(1),e(2),...,e(N-1) are nonzero, +C Sylvester's Law of Inertia may be applied directly to T". +C Otherwise, T" is block diagonal and each diagonal block (which is +C then unreduced) must be analysed separately by applying +C Sylvester's Law of Inertia. +C +C REFERENCES +C +C [1] Parlett, B.N. +C The Symmetric Eigenvalue Problem. +C Prentice Hall, Englewood Cliffs, New Jersey, 1980. +C +C [2] Demmel, J. and Kahan, W. +C Computing Small Singular Values of Bidiagonal Matrices with +C Guaranteed High Relative Accuracy. +C Technical Report, Courant Inst., New York, March 1988. +C +C [3] Van Huffel, S. and Vandewalle, J. +C The Partial Total Least-Squares Algorithm. +C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. +C +C [4] Golub, G.H. and Kahan, W. +C Calculating the Singular Values and Pseudo-inverse of a +C Matrix. +C SIAM J. Numer. Anal., Ser. B, 2, pp. 205-224, 1965. +C +C [5] Demmel, J.W., Dhillon, I. and Ren, H. +C On the Correctness of Parallel Bisection in Floating Point. +C Computer Science Division Technical Report UCB//CSD-94-805, +C University of California, Berkeley, CA 94720, March 1994. +C +C NUMERICAL ASPECTS +C +C The singular values s(i) could also be obtained with the use of +C the symmetric tridiagonal matrix T = J'J, whose eigenvalues are +C the squared singular values of J [4,p.213]. However, the method +C actually used by the routine is more accurate and equally +C efficient (see [2]). +C +C To avoid overflow, matrix J should be scaled so that its largest +C element is no greater than overflow**(1/2) * underflow**(1/4) +C in absolute value (and not much smaller than that, for maximal +C accuracy). +C +C With respect to accuracy the following condition holds (see [2]): +C +C If the established value is denoted by p, then at least p +C singular values of J are less than or equal to +C THETA/(1 - (3 x N - 1.5) x EPS) and no more than p singular values +C are less than or equal to +C THETA x (1 - (6 x N-2) x EPS)/(1 - (3 x N - 1.5) x EPS). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB03BD by S. Van Huffel, Katholieke +C University, Leuven, Belgium. +C +C REVISIONS +C +C July 10, 1997. +C +C KEYWORDS +C +C Bidiagonal matrix, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, N + DOUBLE PRECISION PIVMIN, THETA +C .. Array Arguments .. + DOUBLE PRECISION E2(*), Q2(*) +C .. Local Scalars .. + INTEGER J, NUMEIG + DOUBLE PRECISION R, T +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C +C Test the input scalar arguments. PIVMIN is not checked. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MB03ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. THETA.LT.ZERO ) THEN + MB03ND = 0 + RETURN + END IF +C + NUMEIG = N + T = -THETA + R = T + IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN +C + DO 20 J = 1, N - 1 + R = T - Q2(J)/R + IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN + IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 + R = T - E2(J)/R + IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN + IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 + 20 CONTINUE +C + R = T - Q2(N)/R + IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN + IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1 + MB03ND = NUMEIG +C + RETURN +C *** Last line of MB03ND *** + END diff --git a/mex/sources/libslicot/MB03NY.f b/mex/sources/libslicot/MB03NY.f new file mode 100644 index 000000000..a6efae588 --- /dev/null +++ b/mex/sources/libslicot/MB03NY.f @@ -0,0 +1,208 @@ + DOUBLE PRECISION FUNCTION MB03NY( N, OMEGA, A, LDA, S, DWORK, + $ LDWORK, CWORK, LCWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the smallest singular value of A - jwI. +C +C FUNCTION VALUE +C +C MB03NY DOUBLE PRECISION +C The smallest singular value of A - jwI (if INFO = 0). +C If N = 0, the function value is set to zero. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the the matrix A. N >= 0. +C +C OMEGA (input) DOUBLE PRECISION +C The constant factor of A - jwI. +C +C A (input/workspace) DOUBLE PRECISION array, dimension +C (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, if OMEGA = 0, the contents of this array are +C destroyed. Otherwise, this array is unchanged. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C S (output) DOUBLE PRECISION array, dimension (N) +C The singular values of A - jwI in decreasing order. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX( 1, 5*N ). +C For optimum performance LDWORK should be larger. +C +C CWORK COMPLEX*16 array, dimension (LCWORK) +C On exit, if INFO = 0 and OMEGA <> 0, CWORK(1) returns the +C optimal value of LCWORK. +C If OMEGA is zero, this array is not referenced. +C +C LCWORK INTEGER +C The length of the array CWORK. +C LCWORK >= 1, if OMEGA = 0; +C LCWORK >= MAX( 1, N*N+3*N ), if OMEGA <> 0. +C For optimum performance LCWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: The SVD algorithm (in either LAPACK Library routine +C DGESVD or ZGESVD) fails to converge; this error is +C very rare. +C +C METHOD +C +C This procedure simply constructs the matrix A - jwI, and calls +C ZGESVD if w is not zero, or DGESVD if w = 0. +C +C FURTHER COMMENTS +C +C This routine is not very efficient because it computes all +C singular values, but it is very accurate. The routine is intended +C to be called only from the SLICOT Library routine AB13FD. +C +C CONTRIBUTOR +C +C R. Byers, the routine SIGMIN (January, 1995). +C +C REVISIONS +C +C Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999. +C +C REVISIONS +C +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C Apr. 2002, V. Sima. +C +C KEYWORDS +C +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CONE, RTMONE + PARAMETER ( CONE = ( 1.0D0, 0.0D0 ), + $ RTMONE = ( 0.0D0, 1.0D0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LCWORK, LDA, LDWORK, N + DOUBLE PRECISION OMEGA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), S(*) + COMPLEX*16 CWORK(*) +C .. Local Scalars .. + INTEGER I, IC, J +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1,1) + COMPLEX*16 ZDUMMY(1,1) +C .. External Subroutines .. + EXTERNAL DGESVD, XERBLA, ZGESVD +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDWORK.LT.MAX( 1, 5*N ) ) THEN + INFO = -7 + ELSE IF( LCWORK.LT.1 .OR. ( OMEGA.NE.ZERO .AND. + $ LCWORK.LT.N*N + 3*N ) ) THEN + INFO = -9 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03NY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + MB03NY = ZERO + DWORK(1) = ONE + IF ( OMEGA.NE.ZERO ) + $ CWORK(1) = CONE + RETURN + END IF +C + IF ( OMEGA.EQ.ZERO ) THEN +C +C OMEGA = 0 allows real SVD. +C + CALL DGESVD( 'No vectors', 'No vectors', N, N, A, N, S, DUMMY, + $ 1, DUMMY, 1, DWORK, LDWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF + ELSE +C +C General case, that is complex SVD. +C + IC = 1 + DO 20 J = 1, N + DO 10 I = 1, N + CWORK(IC) = A(I,J) + IC = IC + 1 + 10 CONTINUE + CWORK((J-1)*N+J) = CWORK((J-1)*N+J) - OMEGA * RTMONE + 20 CONTINUE + CALL ZGESVD( 'No vectors', 'No vectors', N, N, CWORK, N, S, + $ ZDUMMY, 1, ZDUMMY, 1, CWORK(N*N+1), LCWORK-N*N, + $ DWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF + CWORK(1) = CWORK(N*N+1) + DBLE( N*N ) * CONE + DWORK(1) = DBLE( 5*N ) + END IF +C + MB03NY = S(N) +C +C *** Last line of MB03NY *** + END diff --git a/mex/sources/libslicot/MB03OD.f b/mex/sources/libslicot/MB03OD.f new file mode 100644 index 000000000..71cb43d66 --- /dev/null +++ b/mex/sources/libslicot/MB03OD.f @@ -0,0 +1,306 @@ + SUBROUTINE MB03OD( JOBQR, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, + $ RANK, SVAL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute (optionally) a rank-revealing QR factorization of a +C real general M-by-N matrix A, which may be rank-deficient, +C and estimate its effective rank using incremental condition +C estimation. +C +C The routine uses a QR factorization with column pivoting: +C A * P = Q * R, where R = [ R11 R12 ], +C [ 0 R22 ] +C with R11 defined as the largest leading submatrix whose estimated +C condition number is less than 1/RCOND. The order of R11, RANK, +C is the effective rank of A. +C +C MB03OD does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBQR CHARACTER*1 +C = 'Q': Perform a QR factorization with column pivoting; +C = 'N': Do not perform the QR factorization (but assume +C that it has been done outside). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry with JOBQR = 'Q', the leading M by N part of this +C array must contain the given matrix A. +C On exit with JOBQR = 'Q', the leading min(M,N) by N upper +C triangular part of A contains the triangular factor R, +C and the elements below the diagonal, with the array TAU, +C represent the orthogonal matrix Q as a product of +C min(M,N) elementary reflectors. +C On entry and on exit with JOBQR = 'N', the leading +C min(M,N) by N upper triangular part of A contains the +C triangular factor R, as determined by the QR factorization +C with pivoting. The elements below the diagonal of A are +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input/output) INTEGER array, dimension ( N ) +C On entry with JOBQR = 'Q', if JPVT(i) <> 0, the i-th +C column of A is an initial column, otherwise it is a free +C column. Before the QR factorization of A, all initial +C columns are permuted to the leading positions; only the +C remaining free columns are moved as a result of column +C pivoting during the factorization. For rank determination +C it is preferable that all columns be free. +C On exit with JOBQR = 'Q', if JPVT(i) = k, then the i-th +C column of A*P was the k-th column of A. +C Array JPVT is not referenced when JOBQR = 'N'. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C RCOND >= 0. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C On exit with JOBQR = 'Q', the leading min(M,N) elements of +C TAU contain the scalar factors of the elementary +C reflectors. +C Array TAU is not referenced when JOBQR = 'N'. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e. the order of +C the submatrix R11. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 3*N + 1, if JOBQR = 'Q'; +C LDWORK >= max( 1, 2*min( M, N ) ), if JOBQR = 'N'. +C For good performance when JOBQR = 'Q', LDWORK should be +C larger. Specifically, LDWORK >= 2*N + ( N + 1 )*NB, where +C NB is the optimal block size for the LAPACK Library +C routine DGEQP3. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes or uses a QR factorization with column +C pivoting of A, A * P = Q * R, with R defined above, and then +C finds the largest leading submatrix whose estimated condition +C number is less than 1/RCOND, taking the possible positive value of +C SVLMAX into account. This is performed using the LAPACK +C incremental condition estimation scheme and a slightly modified +C rank decision test. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBQR + INTEGER INFO, LDA, LDWORK, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) +C .. Local Scalars .. + LOGICAL LJOBQR + INTEGER I, ISMAX, ISMIN, MAXWRK, MINWRK, MN + DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEQP3, DLAIC1, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN +C .. +C .. Executable Statements .. +C + LJOBQR = LSAME( JOBQR, 'Q' ) + MN = MIN( M, N ) + ISMIN = 1 + ISMAX = MN + 1 + IF( LJOBQR ) THEN + MINWRK = 3*N + 1 + ELSE + MINWRK = MAX( 1, 2*MN ) + END IF + MAXWRK = MINWRK +C +C Test the input scalar arguments. +C + INFO = 0 + IF( .NOT.LJOBQR .AND. .NOT.LSAME( JOBQR, 'N' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( RCOND.LT.ZERO ) THEN + INFO = -7 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MINWRK ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03OD', -INFO ) + RETURN + END IF +C +C Quick return if possible +C + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C + IF ( LJOBQR ) THEN +C +C Compute QR factorization with column pivoting of A: +C A * P = Q * R +C Workspace need 3*N + 1; +C prefer 2*N + (N+1)*NB. +C Details of Householder rotations stored in TAU. +C + CALL DGEQP3( M, N, A, LDA, JPVT, TAU, DWORK, LDWORK, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) ) + END IF +C +C Determine RANK using incremental condition estimation +C + DWORK( ISMIN ) = ONE + DWORK( ISMAX ) = ONE + SMAX = ABS( A( 1, 1 ) ) + SMIN = SMAX + IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN + RANK = 0 + SVAL( 1 ) = SMAX + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + ELSE + RANK = 1 + SMINPR = SMIN +C + 10 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN + DO 20 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 20 CONTINUE + DWORK( ISMIN+RANK ) = C1 + DWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 10 + END IF + END IF + END IF + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR + END IF +C + DWORK( 1 ) = MAXWRK + RETURN +C *** Last line of MB03OD *** + END diff --git a/mex/sources/libslicot/MB03OY.f b/mex/sources/libslicot/MB03OY.f new file mode 100644 index 000000000..e39734d55 --- /dev/null +++ b/mex/sources/libslicot/MB03OY.f @@ -0,0 +1,388 @@ + SUBROUTINE MB03OY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a rank-revealing QR factorization of a real general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated QR factorization with column pivoting +C [ R11 R12 ] +C A * P = Q * R, where R = [ ], +C [ 0 R22 ] +C with R11 defined as the largest leading upper triangular submatrix +C whose estimated condition number is less than 1/RCOND. The order +C of R11, RANK, is the effective rank of A. Condition estimation is +C performed during the QR factorization process. Matrix R22 is full +C (but of small norm), or empty. +C +C MB03OY does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the leading RANK-by-RANK upper triangular part +C of A contains the triangular factor R11, and the elements +C below the diagonal in the first RANK columns, with the +C array TAU, represent the orthogonal matrix Q as a product +C of RANK elementary reflectors. +C The remaining N-RANK columns contain the result of the +C QR factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R11. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C JPVT (output) INTEGER array, dimension ( N ) +C If JPVT(i) = k, then the i-th column of A*P was the k-th +C column of A. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C The leading RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 3*N-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of A, A * P = Q * R, with R defined above, and, +C during this process, finds the largest leading submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using the LAPACK incremental condition estimation scheme and a +C slightly modified rank decision test. The factorization process +C stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in +C A(i+1:m,i), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth column of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, orthogonal transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, P05 = 0.05D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) +C .. +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT + DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, + $ SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2, IDAMAX +C .. External Subroutines .. + EXTERNAL DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03OY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( M, N ) + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = 1 + ISMAX = ISMIN + N +C +C Initialize partial column norms and pivoting vector. The first n +C elements of DWORK store the exact column norms. The already used +C leading part is then overwritten by the condition estimator. +C + DO 10 I = 1, N + DWORK( I ) = DNRM2( M, A( 1, I ), 1 ) + DWORK( N+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 +C +C Determine ith pivot column and swap if necessary. +C + PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) +C + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + DWORK( PVT ) = DWORK( I ) + DWORK( N+PVT ) = DWORK( N+I ) + END IF +C +C Save A(I,I) and generate elementary reflector H(i). +C + IF( I.LT.M ) THEN + AII = A( I, I ) + CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) + ELSE + TAU( M ) = ZERO + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( 1, 1 ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Continue factorization, as rank is at least RANK. +C + IF( I.LT.N ) THEN +C +C Apply H(i) to A(i:m,i+1:n) from the left. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ TAU( I ), A( I, I+1 ), LDA, + $ DWORK( 2*N+1 ) ) + A( I, I ) = AII + END IF +C +C Update partial column norms. +C + DO 30 J = I + 1, N + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( N+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + IF( M-I.GT.0 ) THEN + DWORK( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + DWORK( N+J ) = DWORK( J ) + ELSE + DWORK( J ) = ZERO + DWORK( N+J ) = ZERO + END IF + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + DO 40 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 40 CONTINUE +C + DWORK( ISMIN+RANK ) = C1 + DWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (RANK+1)-th column and set SVAL. +C + IF ( RANK.LT.N ) THEN + IF ( I.LT.M ) THEN + CALL DSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = AII + END IF + END IF + IF ( RANK.EQ.0 ) THEN + SMIN = ZERO + SMINPR = ZERO + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB03OY *** + END diff --git a/mex/sources/libslicot/MB03PD.f b/mex/sources/libslicot/MB03PD.f new file mode 100644 index 000000000..5dae93666 --- /dev/null +++ b/mex/sources/libslicot/MB03PD.f @@ -0,0 +1,339 @@ + SUBROUTINE MB03PD( JOBRQ, M, N, A, LDA, JPVT, RCOND, SVLMAX, TAU, + $ RANK, SVAL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute (optionally) a rank-revealing RQ factorization of a +C real general M-by-N matrix A, which may be rank-deficient, +C and estimate its effective rank using incremental condition +C estimation. +C +C The routine uses an RQ factorization with row pivoting: +C P * A = R * Q, where R = [ R11 R12 ], +C [ 0 R22 ] +C with R22 defined as the largest trailing submatrix whose estimated +C condition number is less than 1/RCOND. The order of R22, RANK, +C is the effective rank of A. +C +C MB03PD does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBRQ CHARACTER*1 +C = 'R': Perform an RQ factorization with row pivoting; +C = 'N': Do not perform the RQ factorization (but assume +C that it has been done outside). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry with JOBRQ = 'R', the leading M-by-N part of this +C array must contain the given matrix A. +C On exit with JOBRQ = 'R', +C if M <= N, the upper triangle of the subarray +C A(1:M,N-M+1:N) contains the M-by-M upper triangular +C matrix R; +C if M >= N, the elements on and above the (M-N)-th +C subdiagonal contain the M-by-N upper trapezoidal matrix R; +C the remaining elements, with the array TAU, represent the +C orthogonal matrix Q as a product of min(M,N) elementary +C reflectors (see METHOD). +C On entry and on exit with JOBRQ = 'N', +C if M <= N, the upper triangle of the subarray +C A(1:M,N-M+1:N) must contain the M-by-M upper triangular +C matrix R; +C if M >= N, the elements on and above the (M-N)-th +C subdiagonal must contain the M-by-N upper trapezoidal +C matrix R; +C the remaining elements are not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input/output) INTEGER array, dimension ( M ) +C On entry with JOBRQ = 'R', if JPVT(i) <> 0, the i-th row +C of A is a final row, otherwise it is a free row. Before +C the RQ factorization of A, all final rows are permuted +C to the trailing positions; only the remaining free rows +C are moved as a result of row pivoting during the +C factorization. For rank determination it is preferable +C that all rows be free. +C On exit with JOBRQ = 'R', if JPVT(i) = k, then the i-th +C row of P*A was the k-th row of A. +C Array JPVT is not referenced when JOBRQ = 'N'. +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest trailing triangular +C submatrix R22 in the RQ factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C RCOND >= 0. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C On exit with JOBRQ = 'R', the leading min(M,N) elements of +C TAU contain the scalar factors of the elementary +C reflectors. +C Array TAU is not referenced when JOBRQ = 'N'. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e. the order of +C the submatrix R22. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(2): smallest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), +C if RANK < MIN( M, N ), or of +C R(M-RANK+1:M,N-RANK+1:N), otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the trailing rows were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(M-RANK+1:M,N-RANK+1:N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( LDWORK ) +C where LDWORK = max( 1, 3*M ), if JOBRQ = 'R'; +C LDWORK = max( 1, 3*min( M, N ) ), if JOBRQ = 'N'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes or uses an RQ factorization with row +C pivoting of A, P * A = R * Q, with R defined above, and then +C finds the largest trailing submatrix whose estimated condition +C number is less than 1/RCOND, taking the possible positive value of +C SVLMAX into account. This is performed using an adaptation of the +C LAPACK incremental condition estimation scheme and a slightly +C modified rank decision test. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit +C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Nov. 1996. +C +C REVISIONS +C +C Nov. 1997 +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, orthogonal transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBRQ + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), SVAL( 3 ), TAU( * ), DWORK( * ) +C .. Local Scalars .. + LOGICAL LJOBRQ + INTEGER I, ISMAX, ISMIN, JWORK, MN + DOUBLE PRECISION C1, C2, S1, S2, SMAX, SMAXPR, SMIN, SMINPR +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLAIC1, MB04GD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C + LJOBRQ = LSAME( JOBRQ, 'R' ) + MN = MIN( M, N ) +C +C Test the input scalar arguments. +C + INFO = 0 + IF( .NOT.LJOBRQ .AND. .NOT.LSAME( JOBRQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( RCOND.LT.ZERO ) THEN + INFO = -7 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -8 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + IF ( LJOBRQ ) THEN +C +C Compute RQ factorization with row pivoting of A: +C P * A = R * Q +C Workspace 3*M. Details of Householder rotations stored in TAU. +C + CALL MB04GD( M, N, A, LDA, JPVT, TAU, DWORK( 1 ), INFO ) + END IF +C +C Determine RANK using incremental condition estimation. +C Workspace 3*min(M,N). +C + SMAX = ABS( A( M, N ) ) + IF( SMAX.EQ.ZERO .OR. SVLMAX*RCOND.GT.SMAX ) THEN + RANK = 0 + SVAL( 1 ) = SMAX + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + ELSE + ISMIN = MN + ISMAX = 2*MN + JWORK = ISMAX + 1 + DWORK( ISMIN ) = ONE + DWORK( ISMAX ) = ONE + RANK = 1 + SMIN = SMAX + SMINPR = SMIN +C + 10 CONTINUE + IF( RANK.LT.MN ) THEN + CALL DCOPY ( RANK, A( M-RANK, N-RANK+1 ), LDA, + $ DWORK( JWORK ), 1 ) + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, + $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMINPR, + $ S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, + $ DWORK( JWORK ), A( M-RANK, N-RANK ), SMAXPR, + $ S2, C2 ) +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN + DO 20 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 20 CONTINUE + ISMIN = ISMIN - 1 + ISMAX = ISMAX - 1 + DWORK( ISMIN ) = C1 + DWORK( ISMAX ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 10 + END IF + END IF + END IF + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR + END IF +C + RETURN +C *** Last line of MB03PD *** + END diff --git a/mex/sources/libslicot/MB03PY.f b/mex/sources/libslicot/MB03PY.f new file mode 100644 index 000000000..d0c7d0ca2 --- /dev/null +++ b/mex/sources/libslicot/MB03PY.f @@ -0,0 +1,392 @@ + SUBROUTINE MB03PY( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a rank-revealing RQ factorization of a real general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated RQ factorization with row pivoting: +C [ R11 R12 ] +C P * A = R * Q, where R = [ ], +C [ 0 R22 ] +C with R22 defined as the largest trailing upper triangular +C submatrix whose estimated condition number is less than 1/RCOND. +C The order of R22, RANK, is the effective rank of A. Condition +C estimation is performed during the RQ factorization process. +C Matrix R11 is full (but of small norm), or empty. +C +C MB03PY does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the upper triangle of the subarray +C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper +C triangular matrix R22; the remaining elements in the last +C RANK rows, with the array TAU, represent the orthogonal +C matrix Q as a product of RANK elementary reflectors +C (see METHOD). The first M-RANK rows contain the result +C of the RQ factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest trailing triangular +C submatrix R22 in the RQ factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R22. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(2): smallest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), +C if RANK < MIN( M, N ), or of +C R(M-RANK+1:M,N-RANK+1:N), otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the trailing rows were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(M-RANK+1:M,N-RANK+1:N). +C +C JPVT (output) INTEGER array, dimension ( M ) +C If JPVT(i) = k, then the i-th row of P*A was the k-th row +C of A. +C +C TAU (output) DOUBLE PRECISION array, dimension ( MIN( M, N ) ) +C The trailing RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 3*M-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated RQ factorization with row +C pivoting of A, P * A = R * Q, with R defined above, and, +C during this process, finds the largest trailing submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using an adaptation of the LAPACK incremental condition estimation +C scheme and a slightly modified rank decision test. The +C factorization process stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(k-rank+1) H(k-rank+2) . . . H(k), where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit +C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, +C Jan. 2009. +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, orthogonal transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), SVAL( 3 ), TAU( * ) +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, + $ PVT + DOUBLE PRECISION AII, C1, C2, S1, S2, SMAX, SMAXPR, SMIN, + $ SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DLAIC1, DLARF, DLARFG, DSCAL, DSWAP, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03PY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = M + ISMAX = ISMIN + M + JWORK = ISMAX + 1 +C +C Initialize partial row norms and pivoting vector. The first m +C elements of DWORK store the exact row norms. The already used +C trailing part is then overwritten by the condition estimator. +C + DO 10 I = 1, M + DWORK( I ) = DNRM2( N, A( I, 1 ), LDA ) + DWORK( M+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.K ) THEN + I = K - RANK +C +C Determine ith pivot row and swap if necessary. +C + MKI = M - RANK + NKI = N - RANK + PVT = IDAMAX( MKI, DWORK, 1 ) +C + IF( PVT.NE.MKI ) THEN + CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( MKI ) + JPVT( MKI ) = ITEMP + DWORK( PVT ) = DWORK( MKI ) + DWORK( M+PVT ) = DWORK( M+MKI ) + END IF +C + IF( NKI.GT.1 ) THEN +C +C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) +C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). +C + AII = A( MKI, NKI ) + CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) + $ ) + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( M, N ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DCOPY ( RANK, A( MKI, NKI+1 ), LDA, DWORK( JWORK ), 1 ) + CALL DLAIC1( IMIN, RANK, DWORK( ISMIN ), SMIN, + $ DWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK( ISMAX ), SMAX, + $ DWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C + IF( MKI.GT.1 ) THEN +C +C Continue factorization, as rank is at least RANK. +C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. +C + AII = A( MKI, NKI ) + A( MKI, NKI ) = ONE + CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, + $ TAU( I ), A, LDA, DWORK( JWORK ) ) + A( MKI, NKI ) = AII +C +C Update partial row norms. +C + DO 30 J = 1, MKI - 1 + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( J, NKI ) )/DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( M+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), + $ LDA ) + DWORK( M+J ) = DWORK( J ) + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + END IF +C + DO 40 I = 1, RANK + DWORK( ISMIN+I-1 ) = S1*DWORK( ISMIN+I-1 ) + DWORK( ISMAX+I-1 ) = S2*DWORK( ISMAX+I-1 ) + 40 CONTINUE +C + IF( RANK.GT.0 ) THEN + ISMIN = ISMIN - 1 + ISMAX = ISMAX - 1 + END IF + DWORK( ISMIN ) = C1 + DWORK( ISMAX ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (M-RANK)-th row and set SVAL. +C + IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN + CALL DSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) + A( MKI, NKI ) = AII + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB03PY *** + END diff --git a/mex/sources/libslicot/MB03QD.f b/mex/sources/libslicot/MB03QD.f new file mode 100644 index 000000000..d94eed1bb --- /dev/null +++ b/mex/sources/libslicot/MB03QD.f @@ -0,0 +1,316 @@ + SUBROUTINE MB03QD( DICO, STDOM, JOBU, N, NLOW, NSUP, ALPHA, + $ A, LDA, U, LDU, NDIM, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reorder the diagonal blocks of a principal submatrix of an +C upper quasi-triangular matrix A together with their eigenvalues by +C constructing an orthogonal similarity transformation UT. +C After reordering, the leading block of the selected submatrix of A +C has eigenvalues in a suitably defined domain of interest, usually +C related to stability/instability in a continuous- or discrete-time +C sense. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the spectrum separation to be +C performed as follows: +C = 'C': continuous-time sense; +C = 'D': discrete-time sense. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C JOBU CHARACTER*1 +C Indicates how the performed orthogonal transformations UT +C are accumulated, as follows: +C = 'I': U is initialized to the unit matrix and the matrix +C UT is returned in U; +C = 'U': the given matrix U is updated and the matrix U*UT +C is returned in U. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and U. N >= 1. +C +C NLOW, (input) INTEGER +C NSUP NLOW and NSUP specify the boundary indices for the rows +C and columns of the principal submatrix of A whose diagonal +C blocks are to be reordered. 1 <= NLOW <= NSUP <= N. +C +C ALPHA (input) DOUBLE PRECISION +C The boundary of the domain of interest for the eigenvalues +C of A. If DICO = 'C', ALPHA is the boundary value for the +C real parts of eigenvalues, while for DICO = 'D', +C ALPHA >= 0 represents the boundary value for the moduli of +C eigenvalues. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain a matrix in a real Schur form whose 1-by-1 and +C 2-by-2 diagonal blocks between positions NLOW and NSUP +C are to be reordered. +C On exit, the leading N-by-N part contains the ordered +C real Schur matrix UT' * A * UT with the elements below the +C first subdiagonal set to zero. +C The leading NDIM-by-NDIM part of the principal submatrix +C D = A(NLOW:NSUP,NLOW:NSUP) has eigenvalues in the domain +C of interest and the trailing part of this submatrix has +C eigenvalues outside the domain of interest. +C The domain of interest for lambda(D), the eigenvalues of +C D, is defined by the parameters ALPHA, DICO and STDOM as +C follows: +C For DICO = 'C': +C Real(lambda(D)) < ALPHA if STDOM = 'S'; +C Real(lambda(D)) > ALPHA if STDOM = 'U'. +C For DICO = 'D': +C Abs(lambda(D)) < ALPHA if STDOM = 'S'; +C Abs(lambda(D)) > ALPHA if STDOM = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C On entry with JOBU = 'U', the leading N-by-N part of this +C array must contain a transformation matrix (e.g. from a +C previous call to this routine). +C On exit, if JOBU = 'U', the leading N-by-N part of this +C array contains the product of the input matrix U and the +C orthogonal matrix UT used to reorder the diagonal blocks +C of A. +C On exit, if JOBU = 'I', the leading N-by-N part of this +C array contains the matrix UT of the performed orthogonal +C transformations. +C Array U need not be set on entry if JOBU = 'I'. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C NDIM (output) INTEGER +C The number of eigenvalues of the selected principal +C submatrix lying inside the domain of interest. +C If NLOW = 1, NDIM is also the dimension of the invariant +C subspace corresponding to the eigenvalues of the leading +C NDIM-by-NDIM submatrix. In this case, if U is the +C orthogonal transformation matrix used to compute and +C reorder the real Schur form of A, its first NDIM columns +C form an orthonormal basis for the above invariant +C subspace. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: A(NLOW,NLOW-1) is nonzero, i.e. A(NLOW,NLOW) is not +C the leading element of a 1-by-1 or 2-by-2 diagonal +C block of A, or A(NSUP+1,NSUP) is nonzero, i.e. +C A(NSUP,NSUP) is not the bottom element of a 1-by-1 +C or 2-by-2 diagonal block of A; +C = 2: two adjacent blocks are too close to swap (the +C problem is very ill-conditioned). +C +C METHOD +C +C Given an upper quasi-triangular matrix A with 1-by-1 or 2-by-2 +C diagonal blocks, the routine reorders its diagonal blocks along +C with its eigenvalues by performing an orthogonal similarity +C transformation UT' * A * UT. The column transformation UT is also +C performed on the given (initial) transformation U (resulted from +C a possible previous step or initialized as the identity matrix). +C After reordering, the eigenvalues inside the region specified by +C the parameters ALPHA, DICO and STDOM appear at the top of +C the selected diagonal block between positions NLOW and NSUP. +C In other words, lambda(A(NLOW:NSUP,NLOW:NSUP)) are ordered such +C that lambda(A(NLOW:NLOW+NDIM-1,NLOW:NLOW+NDIM-1)) are inside and +C lambda(A(NLOW+NDIM:NSUP,NLOW+NDIM:NSUP)) are outside the domain +C of interest. If NLOW = 1, the first NDIM columns of U*UT span the +C corresponding invariant subspace of A. +C +C REFERENCES +C +C [1] Stewart, G.W. +C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and +C ordering the eigenvalues of a real upper Hessenberg matrix. +C ACM TOMS, 2, pp. 275-280, 1976. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires less than 4*N operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C April 1998. Based on the RASP routine SEOR1. +C +C KEYWORDS +C +C Eigenvalues, invariant subspace, orthogonal transformation, real +C Schur form, similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBU, STDOM + INTEGER INFO, LDA, LDU, N, NDIM, NLOW, NSUP + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), U(LDU,*) +C .. Local Scalars .. + LOGICAL DISCR, LSTDOM + INTEGER IB, L, LM1, NUP + DOUBLE PRECISION E1, E2, TLAMBD +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DLASET, DTREXC, MB03QY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LSTDOM = LSAME( STDOM, 'S' ) +C +C Check input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSTDOM .OR. LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBU, 'I' ) .OR. + $ LSAME( JOBU, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.1 ) THEN + INFO = -4 + ELSE IF( NLOW.LT.1 ) THEN + INFO = -5 + ELSE IF( NLOW.GT.NSUP .OR. NSUP.GT.N ) THEN + INFO = -6 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.N ) THEN + INFO = -9 + ELSE IF( LDU.LT.N ) THEN + INFO = -11 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QD', -INFO ) + RETURN + END IF +C + IF( NLOW.GT.1 ) THEN + IF( A(NLOW,NLOW-1).NE.ZERO ) INFO = 1 + END IF + IF( NSUP.LT.N ) THEN + IF( A(NSUP+1,NSUP).NE.ZERO ) INFO = 1 + END IF + IF( INFO.NE.0 ) + $ RETURN +C +C Initialize U with an identity matrix if necessary. +C + IF( LSAME( JOBU, 'I' ) ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) +C + NDIM = 0 + L = NSUP + NUP = NSUP +C +C NUP is the minimal value such that the submatrix A(i,j) with +C NUP+1 <= i,j <= NSUP contains no eigenvalues inside the domain of +C interest. L is such that all the eigenvalues of the submatrix +C A(i,j) with L+1 <= i,j <= NUP lie inside the domain of interest. +C +C WHILE( L >= NLOW ) DO +C + 10 IF( L.GE.NLOW ) THEN + IB = 1 + IF( L.GT.NLOW ) THEN + LM1 = L - 1 + IF( A(L,LM1).NE.ZERO ) THEN + CALL MB03QY( N, LM1, A, LDA, U, LDU, E1, E2, INFO ) + IF( A(L,LM1).NE.ZERO ) IB = 2 + END IF + END IF + IF( DISCR ) THEN + IF( IB.EQ.1 ) THEN + TLAMBD = ABS( A(L,L) ) + ELSE + TLAMBD = DLAPY2( E1, E2 ) + END IF + ELSE + IF( IB.EQ.1 ) THEN + TLAMBD = A(L,L) + ELSE + TLAMBD = E1 + END IF + END IF + IF( ( LSTDOM .AND. TLAMBD.LT.ALPHA ) .OR. + $ ( .NOT.LSTDOM .AND. TLAMBD.GT.ALPHA ) ) THEN + NDIM = NDIM + IB + L = L - IB + ELSE + IF( NDIM.NE.0 ) THEN + CALL DTREXC( 'V', N, A, LDA, U, LDU, L, NUP, DWORK, + $ INFO ) + IF( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF + NUP = NUP - 1 + L = L - 1 + ELSE + NUP = NUP - IB + L = L - IB + END IF + END IF + GO TO 10 + END IF +C +C END WHILE 10 +C + RETURN +C *** Last line of MB03QD *** + END diff --git a/mex/sources/libslicot/MB03QX.f b/mex/sources/libslicot/MB03QX.f new file mode 100644 index 000000000..26474ba96 --- /dev/null +++ b/mex/sources/libslicot/MB03QX.f @@ -0,0 +1,122 @@ + SUBROUTINE MB03QX( N, T, LDT, WR, WI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of an upper quasi-triangular matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix T. N >= 0. +C +C T (input) DOUBLE PRECISION array, dimension(LDT,N) +C The upper quasi-triangular matrix T. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C The real and imaginary parts, respectively, of the +C eigenvalues of T. The eigenvalues are stored in the same +C order as on the diagonal of T. If T(i:i+1,i:i+1) is a +C 2-by-2 diagonal block with complex conjugated eigenvalues +C then WI(i) > 0 and WI(i+1) = -WI(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine SEIG. +C +C ****************************************************************** +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDT, N +C .. Array Arguments .. + DOUBLE PRECISION T(LDT, *), WI(*), WR(*) +C .. Local Scalars .. + INTEGER I, I1, INEXT + DOUBLE PRECISION A11, A12, A21, A22, CS, SN +C .. External Subroutines .. + EXTERNAL DLANV2, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QX', -INFO ) + RETURN + END IF +C + INEXT = 1 + DO 10 I = 1, N + IF( I.LT.INEXT ) + $ GO TO 10 + IF( I.NE.N ) THEN + IF( T(I+1,I).NE.ZERO ) THEN +C +C A pair of eigenvalues. +C + INEXT = I + 2 + I1 = I + 1 + A11 = T(I,I) + A12 = T(I,I1) + A21 = T(I1,I) + A22 = T(I1,I1) + CALL DLANV2( A11, A12, A21, A22, WR(I), WI(I), WR(I1), + $ WI(I1), CS, SN ) + GO TO 10 + END IF + END IF +C +C Simple eigenvalue. +C + INEXT = I + 1 + WR(I) = T(I,I) + WI(I) = ZERO + 10 CONTINUE +C + RETURN +C *** Last line of MB03QX *** + END diff --git a/mex/sources/libslicot/MB03QY.f b/mex/sources/libslicot/MB03QY.f new file mode 100644 index 000000000..bf3c8d1ae --- /dev/null +++ b/mex/sources/libslicot/MB03QY.f @@ -0,0 +1,164 @@ + SUBROUTINE MB03QY( N, L, A, LDA, U, LDU, E1, E2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of a selected 2-by-2 diagonal block +C of an upper quasi-triangular matrix, to reduce the selected block +C to the standard form and to split the block in the case of real +C eigenvalues by constructing an orthogonal transformation UT. +C This transformation is applied to A (by similarity) and to +C another matrix U from the right. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and UT. N >= 2. +C +C L (input) INTEGER +C Specifies the position of the block. 1 <= L < N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A whose +C selected 2-by-2 diagonal block is to be processed. +C On exit, the leading N-by-N part of this array contains +C the upper quasi-triangular matrix A after its selected +C block has been splitt and/or put in the LAPACK standard +C form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C On entry, the leading N-by-N part of this array must +C contain a transformation matrix U. +C On exit, the leading N-by-N part of this array contains +C U*UT, where UT is the transformation matrix used to +C split and/or standardize the selected block. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= N. +C +C E1, E2 (output) DOUBLE PRECISION +C E1 and E2 contain either the real eigenvalues or the real +C and positive imaginary parts, respectively, of the complex +C eigenvalues of the selected 2-by-2 diagonal block of A. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let A1 = ( A(L,L) A(L,L+1) ) +C ( A(L+1,L) A(L+1,L+1) ) +C be the specified 2-by-2 diagonal block of matrix A. +C If the eigenvalues of A1 are complex, then they are computed and +C stored in E1 and E2, where the real part is stored in E1 and the +C positive imaginary part in E2. The 2-by-2 block is reduced if +C necessary to the standard form, such that A(L,L) = A(L+1,L+1), and +C A(L,L+1) and A(L+1,L) have oposite signs. If the eigenvalues are +C real, the 2-by-2 block is reduced to an upper triangular form such +C that ABS(A(L,L)) >= ABS(A(L+1,L+1)). +C In both cases, an orthogonal rotation U1' is constructed such that +C U1'*A1*U1 has the appropriate form. Let UT be an extension of U1 +C to an N-by-N orthogonal matrix, using identity submatrices. Then A +C is replaced by UT'*A*UT and the contents of array U is U * UT. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine SPLITB. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalues, orthogonal transformation, real Schur form, +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDU, N + DOUBLE PRECISION E1, E2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), U(LDU,*) +C .. Local Scalars .. + INTEGER L1 + DOUBLE PRECISION EW1, EW2, CS, SN +C .. External Subroutines .. + EXTERNAL DLANV2, DROT, XERBLA +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.2 ) THEN + INFO = -1 + ELSE IF( L.LT.1 .OR. L.GE.N ) THEN + INFO = -2 + ELSE IF( LDA.LT.N ) THEN + INFO = -4 + ELSE IF( LDU.LT.N ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03QY', -INFO ) + RETURN + END IF +C +C Compute the eigenvalues and the elements of the Givens +C transformation. +C + L1 = L + 1 + CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), E1, E2, + $ EW1, EW2, CS, SN ) + IF( E2.EQ.ZERO ) E2 = EW1 +C +C Apply the transformation to A. +C + IF( L1.LT.N ) + $ CALL DROT( N-L1, A(L,L1+1), LDA, A(L1,L1+1), LDA, CS, SN ) + CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) +C +C Accumulate the transformation in U. +C + CALL DROT( N, U(1,L), 1, U(1,L1), 1, CS, SN ) +C + RETURN +C *** Last line of MB03QY *** + END diff --git a/mex/sources/libslicot/MB03RD.f b/mex/sources/libslicot/MB03RD.f new file mode 100644 index 000000000..9d3910d11 --- /dev/null +++ b/mex/sources/libslicot/MB03RD.f @@ -0,0 +1,613 @@ + SUBROUTINE MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS, + $ BLSIZE, WR, WI, TOL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a matrix A in real Schur form to a block-diagonal form +C using well-conditioned non-orthogonal similarity transformations. +C The condition numbers of the transformations used for reduction +C are roughly bounded by PMAX*PMAX, where PMAX is a given value. +C The transformations are optionally postmultiplied in a given +C matrix X. The real Schur form is optionally ordered, so that +C clustered eigenvalues are grouped in the same block. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBX CHARACTER*1 +C Specifies whether or not the transformations are +C accumulated, as follows: +C = 'N': The transformations are not accumulated; +C = 'U': The transformations are accumulated in X (the +C given matrix X is updated). +C +C SORT CHARACTER*1 +C Specifies whether or not the diagonal blocks of the real +C Schur form are reordered, as follows: +C = 'N': The diagonal blocks are not reordered; +C = 'S': The diagonal blocks are reordered before each +C step of reduction, so that clustered eigenvalues +C appear in the same block; +C = 'C': The diagonal blocks are not reordered, but the +C "closest-neighbour" strategy is used instead of +C the standard "closest to the mean" strategy +C (see METHOD); +C = 'B': The diagonal blocks are reordered before each +C step of reduction, and the "closest-neighbour" +C strategy is used (see METHOD). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and X. N >= 0. +C +C PMAX (input) DOUBLE PRECISION +C An upper bound for the infinity norm of elementary +C submatrices of the individual transformations used for +C reduction (see METHOD). PMAX >= 1.0D0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A to be block-diagonalized, in real +C Schur form. +C On exit, the leading N-by-N part of this array contains +C the computed block-diagonal matrix, in real Schur +C canonical form. The non-diagonal blocks are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if JOBX = 'U', the leading N-by-N part of this +C array must contain a given matrix X. +C On exit, if JOBX = 'U', the leading N-by-N part of this +C array contains the product of the given matrix X and the +C transformation matrix that reduced A to block-diagonal +C form. The transformation matrix is itself a product of +C non-orthogonal similarity transformations having elements +C with magnitude less than or equal to PMAX. +C If JOBX = 'N', this array is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. +C LDX >= 1, if JOBX = 'N'; +C LDX >= MAX(1,N), if JOBX = 'U'. +C +C NBLCKS (output) INTEGER +C The number of diagonal blocks of the matrix A. +C +C BLSIZE (output) INTEGER array, dimension (N) +C The first NBLCKS elements of this array contain the orders +C of the resulting diagonal blocks of the matrix A. +C +C WR, (output) DOUBLE PRECISION arrays, dimension (N) +C WI These arrays contain the real and imaginary parts, +C respectively, of the eigenvalues of the matrix A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in the ordering of the diagonal +C blocks of the real Schur form matrix. +C If the user sets TOL > 0, then the given value of TOL is +C used as an absolute tolerance: a block i and a temporarily +C fixed block 1 (the first block of the current trailing +C submatrix to be reduced) are considered to belong to the +C same cluster if their eigenvalues satisfy +C +C | lambda_1 - lambda_i | <= TOL. +C +C If the user sets TOL < 0, then the given value of TOL is +C used as a relative tolerance: a block i and a temporarily +C fixed block 1 are considered to belong to the same cluster +C if their eigenvalues satisfy, for j = 1, ..., N, +C +C | lambda_1 - lambda_i | <= | TOL | * max | lambda_j |. +C +C If the user sets TOL = 0, then an implicitly computed, +C default tolerance, defined by TOL = SQRT( SQRT( EPS ) ) +C is used instead, as a relative tolerance, where EPS is +C the machine precision (see LAPACK Library routine DLAMCH). +C If SORT = 'N' or 'C', this parameter is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Consider first that SORT = 'N'. Let +C +C ( A A ) +C ( 11 12 ) +C A = ( ), +C ( 0 A ) +C ( 22 ) +C +C be the given matrix in real Schur form, where initially A is the +C 11 +C first diagonal block of dimension 1-by-1 or 2-by-2. An attempt is +C made to compute a transformation matrix X of the form +C +C ( I P ) +C X = ( ) (1) +C ( 0 I ) +C +C (partitioned as A), so that +C +C ( A 0 ) +C -1 ( 11 ) +C X A X = ( ), +C ( 0 A ) +C ( 22 ) +C +C and the elements of P do not exceed the value PMAX in magnitude. +C An adaptation of the standard method for solving Sylvester +C equations [1], which controls the magnitude of the individual +C elements of the computed solution [2], is used to obtain matrix P. +C When this attempt failed, an 1-by-1 (or 2-by-2) diagonal block of +C A , whose eigenvalue(s) is (are) the closest to the mean of those +C 22 +C of A is selected, and moved by orthogonal similarity +C 11 +C transformations in the leading position of A ; the moved diagonal +C 22 +C block is then added to the block A , increasing its order by 1 +C 11 +C (or 2). Another attempt is made to compute a suitable +C transformation matrix X with the new definitions of the blocks A +C 11 +C and A . After a successful transformation matrix X has been +C 22 +C obtained, it postmultiplies the current transformation matrix +C (if JOBX = 'U'), and the whole procedure is repeated for the +C matrix A . +C 22 +C +C When SORT = 'S', the diagonal blocks of the real Schur form are +C reordered before each step of the reduction, so that each cluster +C of eigenvalues, defined as specified in the definition of TOL, +C appears in adjacent blocks. The blocks for each cluster are merged +C together, and the procedure described above is applied to the +C larger blocks. Using the option SORT = 'S' will usually provide +C better efficiency than the standard option (SORT = 'N'), proposed +C in [2], because there could be no or few unsuccessful attempts +C to compute individual transformation matrices X of the form (1). +C However, the resulting dimensions of the blocks are usually +C larger; this could make subsequent calculations less efficient. +C +C When SORT = 'C' or 'B', the procedure is similar to that for +C SORT = 'N' or 'S', respectively, but the block of A whose +C 22 +C eigenvalue(s) is (are) the closest to those of A (not to their +C 11 +C mean) is selected and moved to the leading position of A . This +C 22 +C is called the "closest-neighbour" strategy. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Bavely, C. and Stewart, G.W. +C An Algorithm for Computing Reducing Subspaces by Block +C Diagonalization. +C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. +C +C [3] Demmel, J. +C The Condition Number of Equivalence Transformations that +C Block Diagonalize Matrix Pencils. +C SIAM J. Numer. Anal., 20, pp. 599-610, 1983. +C +C NUMERICAL ASPECTS +C 3 4 +C The algorithm usually requires 0(N ) operations, but 0(N ) are +C possible in the worst case, when all diagonal blocks in the real +C Schur form of A are 1-by-1, and the matrix cannot be diagonalized +C by well-conditioned transformations. +C +C FURTHER COMMENTS +C +C The individual non-orthogonal transformation matrices used in the +C reduction of A to a block-diagonal form have condition numbers +C of the order PMAX*PMAX. This does not guarantee that their product +C is well-conditioned enough. The routine can be easily modified to +C provide estimates for the condition numbers of the clusters of +C eigenvalues. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Partly based on the RASP routine BDIAG by A. Varga, German +C Aerospace Center, DLR Oberpfaffenhofen. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. +C +C KEYWORDS +C +C Diagonalization, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBX, SORT + INTEGER INFO, LDA, LDX, N, NBLCKS + DOUBLE PRECISION PMAX, TOL +C .. Array Arguments .. + INTEGER BLSIZE(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) +C .. Local Scalars .. + LOGICAL LJOBX, LSORN, LSORS, LSORT + CHARACTER JOBV + INTEGER DA11, DA22, I, IERR, J, K, L, L11, L22, L22M1 + DOUBLE PRECISION C, CAV, D, EDIF, EMAX, RAV, SAFEMN, SC, THRESH +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLABAD, DLASET, DSCAL, MA02AD, MB03QX, + $ MB03RX, MB03RY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LJOBX = LSAME( JOBX, 'U' ) + LSORN = LSAME( SORT, 'N' ) + LSORS = LSAME( SORT, 'S' ) + LSORT = LSAME( SORT, 'B' ) .OR. LSORS + IF( .NOT.LJOBX .AND. .NOT.LSAME( JOBX, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSORN .AND. .NOT.LSORT .AND. + $ .NOT.LSAME( SORT, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( PMAX.LT.ONE ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( ( LDX.LT.1 ) .OR. ( LJOBX .AND. LDX.LT.N ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NBLCKS = 0 + IF( N.EQ.0 ) + $ RETURN +C +C Set the "safe" minimum positive number with representable +C reciprocal, and set JOBV parameter for MB03RX routine. +C + SAFEMN = DLAMCH( 'Safe minimum' ) + SC = ONE / SAFEMN + CALL DLABAD( SAFEMN, SC ) + SAFEMN = SAFEMN / DLAMCH( 'Precision' ) + JOBV = JOBX + IF ( LJOBX ) + $ JOBV = 'V' +C +C Compute the eigenvalues of A and set the tolerance for reordering +C the eigenvalues in clusters, if needed. +C + CALL MB03QX( N, A, LDA, WR, WI, INFO ) +C + IF ( LSORT ) THEN + THRESH = ABS( TOL ) + IF ( THRESH.EQ.ZERO ) THEN +C +C Use the default tolerance in ordering the blocks. +C + THRESH = SQRT( SQRT( DLAMCH( 'Epsilon' ) ) ) + END IF +C + IF ( TOL.LE.ZERO ) THEN +C +C Use a relative tolerance. Find max | lambda_j |, j = 1 : N. +C + EMAX = ZERO + L = 1 +C WHILE ( L.LE.N ) DO + 10 IF ( L.LE.N ) THEN + IF ( WI(L).EQ.ZERO ) THEN + EMAX = MAX( EMAX, ABS( WR(L) ) ) + L = L + 1 + ELSE + EMAX = MAX( EMAX, DLAPY2( WR(L), WI(L) ) ) + L = L + 2 + END IF + GO TO 10 + END IF +C END WHILE 10 + THRESH = THRESH * EMAX + END IF + END IF +C +C Define the following submatrices of A: +C A11, the DA11-by-DA11 block in position (L11,L11); +C A22, the DA22-by-DA22 block in position (L22,L22); +C A12, the DA11-by-DA22 block in position (L11,L22); +C A21, the DA22-by-DA11 block in position (L22,L11) (null initially +C and finally). +C The following loop uses L11 as loop variable and try to separate a +C block in position (L11,L11), with possibly clustered eigenvalues, +C separated by the other eigenvalues (in the block A22). +C + L11 = 1 +C WHILE ( L11.LE.N ) DO + 20 IF ( L11.LE.N ) THEN + NBLCKS = NBLCKS + 1 + IF ( WI(L11).EQ.ZERO ) THEN + DA11 = 1 + ELSE + DA11 = 2 + END IF +C + IF ( LSORT ) THEN +C +C The following loop, using K as loop variable, finds the +C blocks whose eigenvalues are close to those of A11 and +C moves these blocks (if any) to the leading position of A22. +C + L22 = L11 + DA11 + K = L22 +C WHILE ( K.LE.N ) DO + 30 IF ( K.LE.N ) THEN + EDIF = DLAPY2( WR(L11) - WR(K), WI(L11) - WI(K) ) + IF ( EDIF.LE.THRESH ) THEN +C +C An 1x1 or a 2x2 block of A22 has been found so that +C +C abs( lambda_1 - lambda_k ) <= THRESH +C +C where lambda_1 and lambda_k denote an eigenvalue +C of A11 and of that block in A22, respectively. +C Try to move that block to the leading position of A22. +C + CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, + $ DWORK ) +C +C Extend A11 with the leading block of A22. +C + IF ( WI(L22).EQ.ZERO ) THEN + DA11 = DA11 + 1 + ELSE + DA11 = DA11 + 2 + END IF + L22 = L11 + DA11 + END IF + IF ( WI(K).EQ.ZERO ) THEN + K = K + 1 + ELSE + K = K + 2 + END IF + GO TO 30 + END IF +C END WHILE 30 + END IF +C +C The following loop uses L22 as loop variable and forms a +C separable DA11-by-DA11 block A11 in position (L11,L11). +C + L22 = L11 + DA11 + L22M1 = L22 - 1 +C WHILE ( L22.LE.N ) DO + 40 IF ( L22.LE.N ) THEN + DA22 = N - L22M1 +C +C Try to separate the block A11 of order DA11 by using a +C well-conditioned similarity transformation. +C +C First save A12' in the block A21. +C + CALL MA02AD( 'Full', DA11, DA22, A(L11,L22), LDA, + $ A(L22,L11), LDA ) +C +C Solve -A11*P + P*A22 = A12. +C + CALL MB03RY( DA11, DA22, PMAX, A(L11,L11), LDA, A(L22,L22), + $ LDA, A(L11,L22), LDA, IERR ) +C + IF ( IERR.EQ.1 ) THEN +C +C The annihilation of A12 failed. Restore A12 and A21. +C + CALL MA02AD( 'Full', DA22, DA11, A(L22,L11), LDA, + $ A(L11,L22), LDA ) + CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), + $ LDA ) +C + IF ( LSORN .OR. LSORS ) THEN +C +C Extend A11 with an 1x1 or 2x2 block of A22 having the +C nearest eigenvalues to the mean of eigenvalues of A11 +C and resume the loop. +C First compute the mean of eigenvalues of A11. +C + RAV = ZERO + CAV = ZERO +C + DO 50 I = L11, L22M1 + RAV = RAV + WR(I) + CAV = CAV + ABS( WI(I) ) + 50 CONTINUE +C + RAV = RAV/DA11 + CAV = CAV/DA11 +C +C Loop to find the eigenvalue of A22 nearest to the +C above computed mean. +C + D = DLAPY2( RAV-WR(L22), CAV-WI(L22) ) + K = L22 + IF ( WI(L22).EQ.ZERO ) THEN + L = L22 + 1 + ELSE + L = L22 + 2 + END IF +C WHILE ( L.LE.N ) DO + 60 IF ( L.LE.N ) THEN + C = DLAPY2( RAV-WR(L), CAV-WI(L) ) + IF ( C.LT.D ) THEN + D = C + K = L + END IF + IF ( WI(L).EQ.ZERO ) THEN + L = L + 1 + ELSE + L = L + 2 + END IF + GO TO 60 + END IF +C END WHILE 60 +C + ELSE +C +C Extend A11 with an 1x1 or 2x2 block of A22 having the +C nearest eigenvalues to the cluster of eigenvalues of +C A11 and resume the loop. +C +C Loop to find the eigenvalue of A22 of minimum distance +C to the cluster. +C + D = SC + L = L22 + K = L22 +C WHILE ( L.LE.N ) DO + 70 IF ( L.LE.N ) THEN + I = L11 +C WHILE ( I.LE.L22M1 ) DO + 80 IF ( I.LE.L22M1 ) THEN + C = DLAPY2( WR(I)-WR(L), WI(I)-WI(L) ) + IF ( C.LT.D ) THEN + D = C + K = L + END IF + IF ( WI(I).EQ.ZERO ) THEN + I = I + 1 + ELSE + I = I + 2 + END IF + GO TO 80 + END IF +C END WHILE 80 + IF ( WI(L).EQ.ZERO ) THEN + L = L + 1 + ELSE + L = L + 2 + END IF + GO TO 70 + END IF +C END WHILE 70 + END IF +C +C Try to move block found to the leading position of A22. +C + CALL MB03RX( JOBV, N, L22, K, A, LDA, X, LDX, WR, WI, + $ DWORK ) +C +C Extend A11 with the leading block of A22. +C + IF ( WI(L22).EQ.ZERO ) THEN + DA11 = DA11 + 1 + ELSE + DA11 = DA11 + 2 + END IF + L22 = L11 + DA11 + L22M1 = L22 - 1 + GO TO 40 + END IF + END IF +C END WHILE 40 +C + IF ( LJOBX ) THEN +C +C Accumulate the transformation in X. +C Only columns L22, ..., N are modified. +C + IF ( L22.LE.N ) + $ CALL DGEMM( 'No transpose', 'No transpose', N, DA22, + $ DA11, ONE, X(1,L11), LDX, A(L11,L22), LDA, + $ ONE, X(1,L22), LDX ) +C +C Scale to unity the (non-zero) columns of X which will be +C no more modified and transform A11 accordingly. +C + DO 90 J = L11, L22M1 + SC = DNRM2( N, X(1,J), 1 ) + IF ( SC.GT.SAFEMN ) THEN + CALL DSCAL( DA11, SC, A(J,L11), LDA ) + SC = ONE/SC + CALL DSCAL( N, SC, X(1,J), 1 ) + CALL DSCAL( DA11, SC, A(L11,J), 1 ) + END IF + 90 CONTINUE +C + END IF + IF ( L22.LE.N ) THEN +C +C Set A12 and A21 to zero. +C + CALL DLASET( 'Full', DA11, DA22, ZERO, ZERO, A(L11,L22), + $ LDA ) + CALL DLASET( 'Full', DA22, DA11, ZERO, ZERO, A(L22,L11), + $ LDA ) + END IF +C +C Store the orders of the diagonal blocks in BLSIZE. +C + BLSIZE(NBLCKS) = DA11 + L11 = L22 + GO TO 20 + END IF +C END WHILE 20 +C + RETURN +C *** Last line of MB03RD *** + END diff --git a/mex/sources/libslicot/MB03RX.f b/mex/sources/libslicot/MB03RX.f new file mode 100644 index 000000000..d7c582db5 --- /dev/null +++ b/mex/sources/libslicot/MB03RX.f @@ -0,0 +1,226 @@ + SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI, + $ DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reorder the diagonal blocks of the principal submatrix between +C the indices KL and KU (KU >= KL) of a real Schur form matrix A +C together with their eigenvalues, using orthogonal similarity +C transformations, such that the block specified by KU is moved in +C the position KL. The transformations are optionally postmultiplied +C in a given matrix X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBV CHARACTER*1 +C Specifies whether or not the transformations are +C accumulated, as follows: +C = 'N': The transformations are not accumulated; +C = 'V': The transformations are accumulated in X (the +C given matrix X is updated). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and X. N >= 0. +C +C KL (input) INTEGER +C The lower boundary index for the rows and columns of the +C principal submatrix of A whose diagonal blocks are to be +C reordered, and also the target position for the block to +C be moved. 1 <= KL <= KU <= N. +C +C KU (input/output) INTEGER +C On entry, KU specifies the upper boundary index for the +C rows and columns of the principal submatrix of A whose +C diagonal blocks are to be reordered, and also the original +C position for the block to be moved. 1 <= KL <= KU <= N. +C On exit, KU specifies the upper boundary index for the +C rows and columns of the principal submatrix of A whose +C diagonal blocks have been reordered. The given value will +C be increased by 1 if the moved block was 2-by-2 and it has +C been replaced by two 1-by-1 blocks. Otherwise, its input +C value is preserved. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A in real Schur canonical form. +C On exit, the leading N-by-N part of this array contains +C the ordered real Schur canonical form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if JOBV = 'V', the leading N-by-N part of this +C array must contain a given matrix X. +C On exit, if JOBV = 'V', the leading N-by-N part of this +C array contains the product of the given matrix X and the +C transformation matrix that performed the reordering of A. +C If JOBV = 'N', this array is not referenced. +C +C LDX INTEGER +C The leading dimension of array X. +C LDX >= 1, if JOBV = 'N'; +C LDX >= MAX(1,N), if JOBV = 'V'. +C +C WR, (input/output) DOUBLE PRECISION arrays, dimension (N) +C WI On entry, these arrays must contain the real and imaginary +C parts, respectively, of the eigenvalues of the matrix A. +C On exit, these arrays contain the real and imaginary +C parts, respectively, of the eigenvalues of the matrix A, +C possibly reordered. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C METHOD +C +C An attempt is made to move the block in the position (KU,KU) to +C the position (KL,KL) by a sequence of orthogonal similarity +C transformations, each swapping two consecutive blocks. The +C standard algorithm [1], [2] usually succeeds to perform this +C reordering. A failure of this algorithm means that two consecutive +C blocks (one of them being the desired block possibly moved) are +C too close to swap. In such a case, the leading block of the two +C is tried to be moved in the position (KL,KL) and the procedure is +C repeated. +C +C REFERENCES +C +C [1] Stewart, G.W. +C HQR3 and EXCHQZ: FORTRAN subroutines for calculating and +C ordering the eigenvalues of a real upper Hessenberg matrix. +C ACM TOMS, 2, pp. 275-280, 1976. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. If some eigenvalues are +C ill-conditioned, their returned values could differ much from +C their input values. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBV + INTEGER KL, KU, LDA, LDX, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*) +C .. Local Scalars .. + INTEGER IERR, IFST, ILST, L +C .. External Subroutines .. + EXTERNAL DTREXC +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C + IF ( KU.GT.KL ) THEN +C +C Try to move the block in position (KU,KU) to position (KL,KL). +C + IFST = KU +C REPEAT + 10 CONTINUE + ILST = KL + CALL DTREXC( JOBV, N, A, LDA, X, LDX, IFST, ILST, DWORK, IERR ) + IF ( IERR.NE.0 ) THEN +C +C During calculations, two adjacent blocks were too close +C to swap; the desired block cannot be moved further, but the +C block above it is suitable and is tried for moving. The +C number of repeat cycles is usually 1, and at most the number +C of blocks between the current position and the position KL. +C + IFST = ILST - 1 + IF ( IFST.GT.1 ) THEN + IF ( A(IFST,IFST-1).NE.ZERO ) + $ IFST = ILST - 2 + END IF + IF ( ILST.GT.KL ) + $ GO TO 10 + END IF +C UNTIL ( ILST.EQ.KL on output from DTREXC ) +C +C Recompute the eigenvalues for the modified part of A. +C Note that KU must be incremented if the moved block was 2-by-2 +C and it has been replaced by two 1-by-1 blocks. +C + IF ( WI(KU).NE.ZERO ) THEN + IF ( A(KU+1,KU).EQ.ZERO ) + $ KU = KU + 1 + END IF +C + L = KL +C WHILE ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) DO + 20 IF ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) THEN + IF ( A(L+1,L).NE.ZERO ) THEN +C +C A 2x2 block. +C + WR(L) = A(L,L) + WR(L+1) = WR(L) + WI(L) = SQRT( ABS( A(L,L+1) ) )* + $ SQRT( ABS( A(L+1,L) ) ) + WI(L+1) = -WI(L) + L = L + 2 + ELSE +C +C An 1x1 block. +C + WR(L) = A(L,L) + WI(L) = ZERO + L = L + 1 + END IF + GO TO 20 + ELSE IF ( L.EQ.N ) THEN + WR(L) = A(L,L) + WI(L) = ZERO + END IF +C END WHILE 20 + END IF +C + RETURN +C *** Last line of MB03RX *** + END diff --git a/mex/sources/libslicot/MB03RY.f b/mex/sources/libslicot/MB03RY.f new file mode 100644 index 000000000..550083136 --- /dev/null +++ b/mex/sources/libslicot/MB03RY.f @@ -0,0 +1,261 @@ + SUBROUTINE MB03RY( M, N, PMAX, A, LDA, B, LDB, C, LDC, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the Sylvester equation -AX + XB = C, where A and B are +C M-by-M and N-by-N matrices, respectively, in real Schur form. +C +C This routine is intended to be called only by SLICOT Library +C routine MB03RD. For efficiency purposes, the computations are +C aborted when the infinity norm of an elementary submatrix of X is +C greater than a given value PMAX. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A and the number of rows of the +C matrices C and X. M >= 0. +C +C N (input) INTEGER +C The order of the matrix B and the number of columns of the +C matrices C and X. N >= 0. +C +C PMAX (input) DOUBLE PRECISION +C An upper bound for the infinity norm of an elementary +C submatrix of X (see METHOD). +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain the +C matrix A of the Sylvester equation, in real Schur form. +C The elements below the real Schur form are not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain the +C matrix B of the Sylvester equation, in real Schur form. +C The elements below the real Schur form are not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix C of the Sylvester equation. +C On exit, if INFO = 0, the leading M-by-N part of this +C array contains the solution matrix X of the Sylvester +C equation, and each elementary submatrix of X (see METHOD) +C has the infinity norm less than or equal to PMAX. +C On exit, if INFO = 1, the solution matrix X has not been +C computed completely, because an elementary submatrix of X +C had the infinity norm greater than PMAX. Part of the +C matrix C has possibly been overwritten with the +C corresponding part of X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: an elementary submatrix of X had the infinity norm +C greater than the given value PMAX. +C +C METHOD +C +C The routine uses an adaptation of the standard method for solving +C Sylvester equations [1], which controls the magnitude of the +C individual elements of the computed solution [2]. The equation +C -AX + XB = C can be rewritten as +C p l-1 +C -A X + X B = C + sum A X - sum X B +C kk kl kl ll kl i=k+1 ki il j=1 kj jl +C +C for l = 1:q, and k = p:-1:1, where A , B , C , and X , are +C kk ll kl kl +C block submatrices defined by the partitioning induced by the Schur +C form of A and B, and p and q are the numbers of the diagonal +C blocks of A and B, respectively. So, the elementary submatrices of +C X are found block column by block column, starting from the +C bottom. If any such elementary submatrix has the infinity norm +C greater than the given value PMAX, the calculations are ended. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Bavely, C. and Stewart, G.W. +C An Algorithm for Computing Reducing Subspaces by Block +C Diagonalization. +C SIAM J. Numer. Anal., 16, pp. 359-367, 1979. +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires 0(M N + MN ) operations. +C +C FURTHER COMMENTS +C +C Let +C +C ( A C ) ( I X ) +C M = ( ), Y = ( ). +C ( 0 B ) ( 0 I ) +C +C Then +C +C -1 ( A 0 ) +C Y M Y = ( ), +C ( 0 B ) +C +C hence Y is an non-orthogonal transformation matrix which performs +C the reduction of M to a block-diagonal form. Bounding a norm of +C X is equivalent to setting an upper bound to the condition number +C of the transformation matrix Y. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on the RASP routine SYLSM by A. Varga, German Aerospace +C Center, DLR Oberpfaffenhofen. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Diagonalization, real Schur form, Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, M, N + DOUBLE PRECISION PMAX +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*) +C .. Local Scalars .. + INTEGER DK, DL, I, IERR, J, K, KK, KK1, L, LL, LM1 + DOUBLE PRECISION PNORM, SCALE +C .. Local Arrays .. + DOUBLE PRECISION P(4) +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DGEMM, DGEMV, DLASY2 +C .. Executable Statements .. +C +C For efficiency reasons, this routine does not check the input +C parameters for errors. +C + INFO = 0 +C +C Column loop indexed by L. +C + L = 1 +C WHILE ( L.LE.N ) DO + 10 IF ( L.LE.N ) THEN + LM1 = L - 1 + DL = 1 + IF ( L.LT.N ) THEN + IF ( B(L+1,L).NE.ZERO ) + $ DL = 2 + ENDIF + LL = LM1 + DL + IF ( LM1.GT.0 ) THEN +C +C Update one (or two) column(s) of C. +C + IF ( DL.EQ.2 ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, DL, LM1, + $ -ONE, C, LDC, B(1,L), LDB, ONE, C(1,L), LDC ) + ELSE + CALL DGEMV( 'No transpose', M, LM1, -ONE, C, LDC, B(1,L), + $ 1, ONE, C(1,L), 1 ) + END IF + ENDIF +C +C Row loop indexed by KK. +C + KK = M +C WHILE ( KK.GE.1 ) DO + 20 IF ( KK.GE.1 ) THEN + KK1 = KK + 1 + DK = 1 + IF ( KK.GT.1 ) THEN + IF ( A(KK,KK-1).NE.ZERO ) + $ DK = 2 + ENDIF + K = KK1 - DK + IF ( K.LT.M ) THEN +C +C Update an elementary submatrix of C. +C + DO 40 J = L, LL +C + DO 30 I = K, KK + C(I,J) = C(I,J) + + $ DDOT( M-KK, A(I,KK1), LDA, C(KK1,J), 1 ) + 30 CONTINUE +C + 40 CONTINUE +C + ENDIF + CALL DLASY2( .FALSE., .FALSE., -1, DK, DL, A(K,K), LDA, + $ B(L,L), LDB, C(K,L), LDC, SCALE, P, DK, PNORM, + $ IERR ) + IF( SCALE.NE.ONE .OR. PNORM.GT.PMAX ) THEN + INFO = 1 + RETURN + END IF + C(K,L) = -P(1) + IF ( DL.EQ.1 ) THEN + IF ( DK.EQ.2 ) + $ C(KK,L) = -P(2) + ELSE + IF ( DK.EQ.1 ) THEN + C(K,LL) = -P(2) + ELSE + C(KK,L) = -P(2) + C(K,LL) = -P(3) + C(KK,LL) = -P(4) + ENDIF + ENDIF + KK = KK - DK + GO TO 20 + END IF +C END WHILE 20 + L = L + DL + GO TO 10 + END IF +C END WHILE 10 + RETURN +C *** Last line of MB03RY *** + END diff --git a/mex/sources/libslicot/MB03SD.f b/mex/sources/libslicot/MB03SD.f new file mode 100644 index 000000000..679396e77 --- /dev/null +++ b/mex/sources/libslicot/MB03SD.f @@ -0,0 +1,348 @@ + SUBROUTINE MB03SD( JOBSCL, N, A, LDA, QG, LDQG, WR, WI, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of an N-by-N square-reduced Hamiltonian +C matrix +C +C ( A' G' ) +C H' = ( T ). (1) +C ( Q' -A' ) +C +C Here, A' is an N-by-N matrix, and G' and Q' are symmetric N-by-N +C matrices. It is assumed without a check that H' is square- +C reduced, i.e., that +C +C 2 ( A'' G'' ) +C H' = ( T ) with A'' upper Hessenberg. (2) +C ( 0 A'' ) +C +C T 2 +C (Equivalently, Q'A'- A' Q' = 0, A'' = A' + G'Q', and for i > j+1, +C A''(i,j) = 0.) Ordinarily, H' is the output from SLICOT Library +C routine MB04ZD. The eigenvalues of H' are computed as the square +C roots of the eigenvalues of A''. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBSCL CHARACTER*1 +C Specifies whether or not balancing operations should +C be performed by the LAPACK subroutine DGEBAL on the +C Hessenberg matrix A'' in (2), as follows: +C = 'N': do not use balancing; +C = 'S': do scaling in order to equilibrate the rows +C and columns of A''. +C See LAPACK subroutine DGEBAL and Section METHOD below. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C upper left block A' of the square-reduced Hamiltonian +C matrix H' in (1), as produced by SLICOT Library routine +C MB04ZD. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input) DOUBLE PRECISION array, dimension (LDQG,N+1) +C The leading N-by-N lower triangular part of this array +C must contain the lower triangle of the lower left +C symmetric block Q' of the square-reduced Hamiltonian +C matrix H' in (1), and the N-by-N upper triangular part of +C the submatrix in the columns 2 to N+1 of this array must +C contain the upper triangle of the upper right symmetric +C block G' of the square-reduced Hamiltonian matrix H' +C in (1), as produced by SLICOT Library routine MB04ZD. +C So, if i >= j, then Q'(i,j) is stored in QG(i,j) and +C G'(i,j) is stored in QG(j,i+1). +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C The arrays WR and WI contain the real and imaginary parts, +C respectively, of the N eigenvalues of H' with non-negative +C real part. The remaining N eigenvalues are the negatives +C of these eigenvalues. +C Eigenvalues are stored in WR and WI in decreasing order of +C magnitude of the real parts, i.e., WR(I) >= WR(I+1). +C (In particular, an eigenvalue closest to the imaginary +C axis is WR(N)+WI(N)i.) +C In addition, eigenvalues with zero real part are sorted in +C decreasing order of magnitude of imaginary parts. Note +C that non-real eigenvalues with non-zero real part appear +C in complex conjugate pairs, but eigenvalues with zero real +C part do not, in general, appear in complex conjugate +C pairs. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1,N*(N+1)). +C For good performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, then the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, then LAPACK subroutine DHSEQR +C failed to converge while computing the i-th +C eigenvalue. +C +C METHOD +C +C The routine forms the upper Hessenberg matrix A'' in (2) and calls +C LAPACK subroutines to calculate its eigenvalues. The eigenvalues +C of H' are the square roots of the eigenvalues of A''. +C +C REFERENCES +C +C [1] Van Loan, C. F. +C A Symplectic Method for Approximating All the Eigenvalues of +C a Hamiltonian Matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] Byers, R. +C Hamiltonian and Symplectic Algorithms for the Algebraic +C Riccati Equation. +C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. +C +C [3] Benner, P., Byers, R., and Barth, E. +C Fortran 77 Subroutines for Computing the Eigenvalues of +C Hamiltonian Matrices. I: The Square-Reduced Method. +C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. +C +C NUMERICAL ASPECTS +C +C The algorithm requires (32/3)*N**3 + O(N**2) floating point +C operations. +C Eigenvalues computed by this subroutine are exact eigenvalues +C of a perturbed Hamiltonian matrix H' + E where +C +C || E || <= c sqrt(eps) || H' ||, +C +C c is a modest constant depending on the dimension N and eps is the +C machine precision. Moreover, if the norm of H' and an eigenvalue +C are of roughly the same magnitude, the computed eigenvalue is +C essentially as accurate as the computed eigenvalue obtained by +C traditional methods. See [1] or [2]. +C +C CONTRIBUTOR +C +C P. Benner, Universitaet Bremen, Germany, and +C R. Byers, University of Kansas, Lawrence, USA. +C Aug. 1998, routine DHAEVS. +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998, SLICOT Library version. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 2002, +C May 2009. +C +C KEYWORDS +C +C Eigenvalues, (square-reduced) Hamiltonian matrix, symplectic +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDQG, LDWORK, N + CHARACTER JOBSCL +C .. +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), WI(*), WR(*) +C .. +C .. Local Scalars .. + DOUBLE PRECISION SWAP, X, Y + INTEGER BL, CHUNK, I, IGNORE, IHI, ILO, J, JW, JWORK, M, + $ N2 + LOGICAL BLAS3, BLOCK, SCALE, SORTED +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DLASET, + $ DSYMM, DSYMV, MA01AD, MA02ED, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + N2 = N*N + SCALE = LSAME( JOBSCL, 'S' ) + IF ( .NOT. ( SCALE .OR. LSAME( JOBSCL, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDWORK.LT.MAX( 1, N2 + N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + CHUNK = ( LDWORK - N2 ) / N + BLOCK = MIN( CHUNK, N ).GT.1 + BLAS3 = CHUNK.GE.N +C + IF ( BLAS3 ) THEN + JWORK = N2 + 1 + ELSE + JWORK = 1 + END IF +C 2 +C Form the matrix A'' = A' + G'Q'. +C + CALL DLACPY( 'Lower', N, N, QG, LDQG, DWORK(JWORK), N ) + CALL MA02ED( 'Lower', N, DWORK(JWORK), N ) +C + IF ( BLAS3 ) THEN +C +C Use BLAS 3 calculation. +C + CALL DSYMM( 'Left', 'Upper', N, N, ONE, QG(1, 2), LDQG, + $ DWORK(JWORK), N, ZERO, DWORK, N ) +C + ELSE IF ( BLOCK ) THEN + JW = N2 + 1 +C +C Use BLAS 3 for as many columns of Q' as possible. +C + DO 10 J = 1, N, CHUNK + BL = MIN( N-J+1, CHUNK ) + CALL DSYMM( 'Left', 'Upper', N, BL, ONE, QG(1, 2), LDQG, + $ DWORK(1+N*(J-1)), N, ZERO, DWORK(JW), N ) + CALL DLACPY( 'Full', N, BL, DWORK(JW), N, DWORK(1+N*(J-1)), + $ N ) + 10 CONTINUE +C + ELSE +C +C Use BLAS 2 calculation. +C + DO 20 J = 1, N + CALL DSYMV( 'Upper', N, ONE, QG(1, 2), LDQG, + $ DWORK(1+N*(J-1)), 1, ZERO, WR, 1 ) + CALL DCOPY( N, WR, 1, DWORK(1+N*(J-1)), 1 ) + 20 CONTINUE +C + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, A, LDA, A, + $ LDA, ONE, DWORK, N ) + IF ( SCALE .AND. N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK(3), N ) +C 2 +C Find the eigenvalues of A' + G'Q'. +C + CALL DGEBAL( JOBSCL, N, DWORK, N, ILO, IHI, DWORK(1+N2), IGNORE ) + CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI, DWORK, + $ N, WR, WI, DUMMY, 1, DWORK(1+N2), N, INFO ) + IF ( INFO.EQ.0 ) THEN +C +C Eigenvalues of H' are the square roots of those computed above. +C + DO 30 I = 1, N + X = WR(I) + Y = WI(I) + CALL MA01AD( X, Y, WR(I), WI(I) ) + 30 CONTINUE +C +C Sort eigenvalues into decreasing order by real part and, for +C eigenvalues with zero real part only, decreasing order of +C imaginary part. (This simple bubble sort preserves the +C relative order of eigenvalues with equal but nonzero real part. +C This ensures that complex conjugate pairs remain +C together.) +C + SORTED = .FALSE. +C + DO 50 M = N, 1, -1 + IF ( SORTED ) GO TO 60 + SORTED = .TRUE. +C + DO 40 I = 1, M - 1 + IF ( ( ( WR(I).LT.WR(I+1) ) .OR. + $ ( ( WR(I).EQ.ZERO ) .AND. ( WR(I+1).EQ.ZERO ) .AND. + $ ( WI(I).LT.WI(I+1) ) ) ) ) THEN + SWAP = WR(I) + WR(I) = WR(I+1) + WR(I+1) = SWAP + SWAP = WI(I) + WI(I) = WI(I+1) + WI(I+1) = SWAP +C + SORTED = .FALSE. +C + END IF + 40 CONTINUE +C + 50 CONTINUE +C + 60 CONTINUE +C + END IF +C + DWORK(1) = 2*N2 + RETURN +C *** Last line of MB03SD *** + END diff --git a/mex/sources/libslicot/MB03TD.f b/mex/sources/libslicot/MB03TD.f new file mode 100644 index 000000000..05561446d --- /dev/null +++ b/mex/sources/libslicot/MB03TD.f @@ -0,0 +1,641 @@ + SUBROUTINE MB03TD( TYP, COMPU, SELECT, LOWER, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, WR, WI, M, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reorder a matrix X in skew-Hamiltonian Schur form: +C +C [ A G ] T +C X = [ T ], G = -G, +C [ 0 A ] +C +C or in Hamiltonian Schur form: +C +C [ A G ] T +C X = [ T ], G = G, +C [ 0 -A ] +C +C where A is in upper quasi-triangular form, so that a selected +C cluster of eigenvalues appears in the leading diagonal blocks +C of the matrix A (in X) and the leading columns of [ U1; -U2 ] form +C an orthonormal basis for the corresponding right invariant +C subspace. +C +C If X is skew-Hamiltonian, then each eigenvalue appears twice; one +C copy corresponds to the j-th diagonal element and the other to the +C (n+j)-th diagonal element of X. The logical array LOWER controls +C which copy is to be reordered to the leading part of A. +C +C If X is Hamiltonian then the eigenvalues appear in pairs +C (lambda,-lambda); lambda corresponds to the j-th diagonal +C element and -lambda to the (n+j)-th diagonal element of X. +C The logical array LOWER controls whether lambda or -lambda is to +C be reordered to the leading part of A. +C +C The matrix A must be in Schur canonical form (as returned by the +C LAPACK routine DHSEQR), that is, block upper triangular with +C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has +C its diagonal elements equal and its off-diagonal elements of +C opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C TYP CHARACTER*1 +C Specifies the type of the input matrix X: +C = 'S': X is skew-Hamiltonian; +C = 'H': X is Hamiltonian. +C +C COMPU CHARACTER*1 +C = 'U': update the matrices U1 and U2 containing the +C Schur vectors; +C = 'N': do not update U1 and U2. +C +C SELECT (input/output) LOGICAL array, dimension (N) +C SELECT specifies the eigenvalues in the selected cluster. +C To select a real eigenvalue w(j), SELECT(j) must be set +C to .TRUE.. To select a complex conjugate pair of +C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 +C diagonal block, both SELECT(j) and SELECT(j+1) must be set +C to .TRUE.; a complex conjugate pair of eigenvalues must be +C either both included in the cluster or both excluded. +C +C LOWER (input/output) LOGICAL array, dimension (N) +C LOWER controls which copy of a selected eigenvalue is +C included in the cluster. If SELECT(j) is set to .TRUE. +C for a real eigenvalue w(j); then LOWER(j) must be set to +C .TRUE. if the eigenvalue corresponding to the (n+j)-th +C diagonal element of X is to be reordered to the leading +C part; and LOWER(j) must be set to .FALSE. if the +C eigenvalue corresponding to the j-th diagonal element of +C X is to be reordered to the leading part. Similarly, for +C a complex conjugate pair of eigenvalues w(j) and w(j+1), +C both LOWER(j) and LOWER(j+1) must be set to .TRUE. if the +C eigenvalues corresponding to the (n+j:n+j+1,n+j:n+j+1) +C diagonal block of X are to be reordered to the leading +C part. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A in Schur +C canonical form. +C On exit, the leading N-by-N part of this array contains +C the reordered matrix A, again in Schur canonical form, +C with the selected eigenvalues in the diagonal blocks. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, if TYP = 'S', the leading N-by-N part of this +C array must contain the strictly upper triangular part of +C the skew-symmetric matrix G. The rest of this array is not +C referenced. +C On entry, if TYP = 'H', the leading N-by-N part of this +C array must contain the upper triangular part of the +C symmetric matrix G. The rest of this array is not +C referenced. +C On exit, if TYP = 'S', the leading N-by-N part of this +C array contains the strictly upper triangular part of the +C skew-symmetric matrix G, updated by the orthogonal +C symplectic transformation which reorders X. +C On exit, if TYP = 'H', the leading N-by-N part of this +C array contains the upper triangular part of the symmetric +C matrix G, updated by the orthogonal symplectic +C transformation which reorders X. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, if COMPU = 'U', the leading N-by-N part of this +C array must contain U1, the (1,1) block of an orthogonal +C symplectic matrix U = [ U1, U2; -U2, U1 ]. +C On exit, if COMPU = 'U', the leading N-by-N part of this +C array contains the (1,1) block of the matrix U, +C postmultiplied by the orthogonal symplectic transformation +C which reorders X. The leading M columns of U form an +C orthonormal basis for the specified invariant subspace. +C If COMPU = 'N', this array is not referenced. +C +C LDU1 INTEGER +C The leading dimension of the array U1. +C LDU1 >= MAX(1,N), if COMPU = 'U'; +C LDU1 >= 1, otherwise. +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, if COMPU = 'U', the leading N-by-N part of this +C array must contain U2, the (1,2) block of an orthogonal +C symplectic matrix U = [ U1, U2; -U2, U1 ]. +C On exit, if COMPU = 'U', the leading N-by-N part of this +C array contains the (1,2) block of the matrix U, +C postmultiplied by the orthogonal symplectic transformation +C which reorders X. +C If COMPU = 'N', this array is not referenced. +C +C LDU2 INTEGER +C The leading dimension of the array U2. +C LDU2 >= MAX(1,N), if COMPU = 'U'; +C LDU2 >= 1, otherwise. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C The real and imaginary parts, respectively, of the +C reordered eigenvalues of A. The eigenvalues are stored +C in the same order as on the diagonal of A, with +C WR(i) = A(i,i) and, if A(i:i+1,i:i+1) is a 2-by-2 diagonal +C block, WI(i) > 0 and WI(i+1) = -WI(i). Note that if an +C eigenvalue is sufficiently ill-conditioned, then its value +C may differ significantly from its value before reordering. +C +C M (output) INTEGER +C The dimension of the specified invariant subspace. +C 0 <= M <= N. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -18, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C = 1: reordering of X failed because some eigenvalue pairs +C are too close to separate (the problem is very +C ill-conditioned); X may have been partially +C reordered, and WR and WI contain the eigenvalues in +C the same order as in X. +C +C REFERENCES +C +C [1] Bai, Z. and Demmel, J.W. +C On Swapping Diagonal Blocks in Real Schur Form. +C Linear Algebra Appl., 186, pp. 73-95, 1993. +C +C [2] Benner, P., Kressner, D., and Mehrmann, V. +C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, +C Algorithms and Applications. Techn. Report, TU Berlin, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAORD). +C +C KEYWORDS +C +C Hamiltonian matrix, skew-Hamiltonian matrix, invariant subspace. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPU, TYP + INTEGER INFO, LDA, LDG, LDU1, LDU2, LDWORK, M, N +C .. Array Arguments .. + LOGICAL LOWER(*), SELECT(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), + $ U2(LDU2,*), WI(*), WR(*) +C .. Local Scalars .. + LOGICAL FLOW, ISHAM, PAIR, SWAP, WANTU + INTEGER HERE, IERR, IFST, ILST, K, KS, NBF, NBL, NBNEXT, + $ WRKMIN +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL MB03TS, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Decode and check input parameters. +C + ISHAM = LSAME( TYP, 'H' ) + WANTU = LSAME( COMPU, 'U' ) + WRKMIN = MAX( 1, N ) + INFO = 0 + IF ( .NOT.ISHAM .AND. .NOT.LSAME( TYP, 'S' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN + INFO = -11 + ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN + INFO = -13 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + INFO = -18 + DWORK(1) = DBLE( WRKMIN ) + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03TD', -INFO ) + RETURN + END IF +C +C Set M to the dimension of the specified invariant subspace. +C + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF ( K.LT.N ) THEN + IF ( A(K+1,K).EQ.ZERO ) THEN + IF ( SELECT(K) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF ( SELECT(K) .OR. SELECT(K+1) ) + $ M = M + 2 + END IF + ELSE + IF ( SELECT(N) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Collect the selected blocks at the top-left corner of X. +C + KS = 0 + PAIR = .FALSE. + DO 60 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + SWAP = SELECT(K) + FLOW = LOWER(K) + IF ( K.LT.N ) THEN + IF ( A(K+1,K).NE.ZERO ) THEN + PAIR = .TRUE. + SWAP = SWAP.OR.SELECT(K+1) + FLOW = FLOW.OR.LOWER(K+1) + END IF + END IF +C + IF ( PAIR ) THEN + NBF = 2 + ELSE + NBF = 1 + END IF +C + IF ( SWAP ) THEN + KS = KS + 1 + IF ( FLOW ) THEN +C +C Step 1: Swap the K-th block to position N. +C + IFST = K + ILST = N + NBL = 1 + IF ( ILST.GT.1 ) THEN + IF ( A(ILST,ILST-1).NE.ZERO ) THEN + ILST = ILST - 1 + NBL = 2 + END IF + END IF +C +C Update ILST. +C + IF ( NBF.EQ.2 .AND. NBL.EQ.1 ) + $ ILST = ILST - 1 + IF ( NBF.EQ.1 .AND. NBL.EQ.2 ) + $ ILST = ILST + 1 +C + IF ( ILST.EQ.IFST ) + $ GO TO 30 +C + HERE = IFST +C + 20 CONTINUE +C +C Swap block with next one below. +C + IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +C +C Current block is either 1-by-1 or 2-by-2. +C + NBNEXT = 1 + IF ( HERE+NBF+1.LE.N ) THEN + IF ( A(HERE+NBF+1,HERE+NBF).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE, NBF, NBNEXT, + $ DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + HERE = HERE + NBNEXT +C +C Test if 2-by-2 block breaks into two 1-by-1 blocks. +C + IF ( NBF.EQ.2 ) THEN + IF ( A(HERE+1,HERE).EQ.ZERO ) + $ NBF = 3 + END IF +C + ELSE +C +C Current block consists of two 1-by-1 blocks each of +C which must be swapped individually. +C + NBNEXT = 1 + IF ( HERE+3.LE.N ) THEN + IF ( A(HERE+3,HERE+2).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE+1, 1, NBNEXT, + $ DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + IF ( NBNEXT.EQ.1 ) THEN +C +C Swap two 1-by-1 blocks, no problems possible. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE, 1, + $ NBNEXT, DWORK, IERR ) + HERE = HERE + 1 + ELSE +C +C Recompute NBNEXT in case 2 by 2 split. +C + IF ( A(HERE+2,HERE+1).EQ.ZERO ) + $ NBNEXT = 1 + IF ( NBNEXT.EQ.2 ) THEN +C +C 2-by-2 block did not split +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE, 1, + $ NBNEXT, DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + HERE = HERE + 2 + ELSE +C +C 2-by-2 block did split +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE, 1, 1, + $ DWORK, IERR ) + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE+1, 1, + $ 1, DWORK, IERR ) + HERE = HERE + 2 + END IF + END IF + END IF + IF ( HERE.LT.ILST ) + $ GO TO 20 +C + 30 CONTINUE +C +C Step 2: Apply an orthogonal symplectic transformation +C to swap the last blocks in A and -A' (or A'). +C + IF ( NBF.EQ.1 ) THEN +C +C Exchange columns/rows N <-> 2*N. No problems +C possible. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, N, 1, 1, + $ DWORK, IERR ) +C + ELSE IF ( NBF.EQ.2 ) THEN +C +C Swap last block with its equivalent by an +C orthogonal symplectic transformation. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, N-1, 2, 2, + $ DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF +C +C Test if 2-by-2 block breaks into two 1-by-1 blocks. +C + IF ( A(N-1,N).EQ.ZERO ) + $ NBF = 3 + ELSE +C +C Block did split. Swap (N-1)-th and N-th elements +C consecutively by symplectic generalized +C permutations and one rotation. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, N-1, 1, 1, DWORK, + $ IERR ) + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, N, 1, 1, DWORK, IERR ) + END IF + IFST = N + IF ( PAIR ) + $ IFST = N-1 + ELSE + IFST = K + END IF +C +C Step 3: Swap the K-th / N-th block to position KS. +C + ILST = KS + NBL = 1 + IF ( ILST.GT.1 ) THEN + IF ( A(ILST,ILST-1).NE.ZERO ) THEN + ILST = ILST - 1 + NBL = 2 + END IF + END IF +C + IF ( ILST.EQ.IFST ) + $ GO TO 50 +C + HERE = IFST + 40 CONTINUE +C +C Swap block with next one above. +C + IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +C +C Current block either 1 by 1 or 2 by 2. +C + NBNEXT = 1 + IF ( HERE.GE.3 ) THEN + IF ( A(HERE-1,HERE-2).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, + $ NBF, DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + HERE = HERE - NBNEXT +C +C Test if 2-by-2 block breaks into two 1-by-1 blocks. +C + IF ( NBF.EQ.2 ) THEN + IF ( A(HERE+1,HERE).EQ.ZERO ) + $ NBF = 3 + END IF +C + ELSE +C +C Current block consists of two 1 by 1 blocks each of +C which must be swapped individually. +C + NBNEXT = 1 + IF ( HERE.GE.3 ) THEN + IF ( A(HERE-1,HERE-2).NE.ZERO ) + $ NBNEXT = 2 + END IF + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE-NBNEXT, NBNEXT, + $ 1, DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + IF ( NBNEXT.EQ.1 ) THEN +C +C Swap two 1-by-1 blocks, no problems possible. +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, + $ LDU1, U2, LDU2, HERE, NBNEXT, 1, + $ DWORK, IERR ) + + HERE = HERE - 1 + ELSE +C +C Recompute NBNEXT in case 2-by-2 split. +C + IF ( A(HERE,HERE-1).EQ.ZERO ) + $ NBNEXT = 1 + IF ( NBNEXT.EQ.2 ) THEN +C +C 2-by-2 block did not split +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE-1, 2, 1, + $ DWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + GO TO 70 + END IF + HERE = HERE - 2 + ELSE +C +C 2-by-2 block did split +C + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE, 1, 1, + $ DWORK, IERR ) + CALL MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, + $ U1, LDU1, U2, LDU2, HERE-1, 1, 1, + $ DWORK, IERR ) + HERE = HERE - 2 + END IF + END IF + END IF +C + IF ( HERE.GT.ILST ) + $ GO TO 40 +C + 50 CONTINUE + IF ( PAIR ) + $ KS = KS + 1 + END IF + END IF + 60 CONTINUE +C + 70 CONTINUE +C +C Store eigenvalues. +C + DO 80 K = 1, N + WR(K) = A(K,K) + WI(K) = ZERO + 80 CONTINUE + DO 90 K = 1, N - 1 + IF ( A(K+1,K).NE.ZERO ) THEN + WI(K) = SQRT( ABS( A(K,K+1) ) )* + $ SQRT( ABS( A(K+1,K) ) ) + WI(K+1) = -WI(K) + END IF + 90 CONTINUE +C + DWORK(1) = DBLE( WRKMIN ) +C + RETURN +C *** Last line of MB03TD *** + END diff --git a/mex/sources/libslicot/MB03TS.f b/mex/sources/libslicot/MB03TS.f new file mode 100644 index 000000000..202e72f5b --- /dev/null +++ b/mex/sources/libslicot/MB03TS.f @@ -0,0 +1,746 @@ + SUBROUTINE MB03TS( ISHAM, WANTU, N, A, LDA, G, LDG, U1, LDU1, U2, + $ LDU2, J1, N1, N2, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To swap diagonal blocks A11 and A22 of order 1 or 2 in the upper +C quasi-triangular matrix A contained in a skew-Hamiltonian matrix +C +C [ A G ] T +C X = [ T ], G = -G, +C [ 0 A ] +C +C or in a Hamiltonian matrix +C +C [ A G ] T +C X = [ T ], G = G. +C [ 0 -A ] +C +C This routine is a modified version of the LAPACK subroutine +C DLAEX2. +C +C The matrix A must be in Schur canonical form (as returned by the +C LAPACK routine DHSEQR), that is, block upper triangular with +C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has +C its diagonal elements equal and its off-diagonal elements of +C opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C ISHAM LOGIGAL +C Specifies the type of X: +C = .TRUE.: X is a Hamiltonian matrix; +C = .FALSE.: X is a skew-Hamiltonian matrix. +C +C WANTU LOGIGAL +C = .TRUE.: update the matrices U1 and U2 containing the +C Schur vectors; +C = .FALSE.: do not update U1 and U2. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A, in Schur +C canonical form. +C On exit, the leading N-by-N part of this array contains +C the reordered matrix A, again in Schur canonical form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular part of the symmetric +C matrix G, if ISHAM = .TRUE., or the strictly upper +C triangular part of the skew-symmetric matrix G, otherwise. +C The rest of this array is not referenced. +C On exit, the leading N-by-N part of this array contains +C the upper or strictly upper triangular part of the +C symmetric or skew-symmetric matrix G, respectively, +C updated by the orthogonal transformation which reorders A. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, if WANTU = .TRUE., the leading N-by-N part of +C this array must contain the matrix U1. +C On exit, if WANTU = .TRUE., the leading N-by-N part of +C this array contains U1, postmultiplied by the orthogonal +C transformation which reorders A. See the description in +C the SLICOT subroutine MB03TD for further details. +C If WANTU = .FALSE., this array is not referenced. +C +C LDU1 INTEGER +C The leading dimension of the array U1. +C LDU1 >= MAX(1,N), if WANTU = .TRUE.; +C LDU1 >= 1, otherwise. +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, if WANTU = .TRUE., the leading N-by-N part of +C this array must contain the matrix U2. +C On exit, if WANTU = .TRUE., the leading N-by-N part of +C this array contains U2, postmultiplied by the orthogonal +C transformation which reorders A. +C If WANTU = .FALSE., this array is not referenced. +C +C LDU2 INTEGER +C The leading dimension of the array U2. +C LDU2 >= MAX(1,N), if WANTU = .TRUE.; +C LDU2 >= 1, otherwise. +C +C J1 (input) INTEGER +C The index of the first row of the first block A11. +C If J1+N1 < N, then A11 is swapped with the block starting +C at (J1+N1+1)-th diagonal element. +C If J1+N1 > N, then A11 is the last block in A and swapped +C with -A11', if ISHAM = .TRUE., +C or A11', if ISHAM = .FALSE.. +C +C N1 (input) INTEGER +C The order of the first block A11. N1 = 0, 1 or 2. +C +C N2 (input) INTEGER +C The order of the second block A22. N2 = 0, 1 or 2. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: the transformed matrix A would be too far from Schur +C form; the blocks are not swapped and A, G, U1 and +C U2 are unchanged. +C +C REFERENCES +C +C [1] Bai, Z., and Demmel, J.W. +C On swapping diagonal blocks in real Schur form. +C Linear Algebra Appl., 186, pp. 73-95, 1993. +C +C [2] Benner, P., Kressner, D., and Mehrmann, V. +C Skew-Hamiltonian and Hamiltonian Eigenvalue Problems: Theory, +C Algorithms and Applications. Techn. Report, TU Berlin, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAEX2). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO, THIRTY, FORTY + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0, THIRTY = 3.0D+1, + $ FORTY = 4.0D+1 ) + INTEGER LDD, LDX + PARAMETER ( LDD = 4, LDX = 2 ) +C .. Scalar Arguments .. + LOGICAL ISHAM, WANTU + INTEGER INFO, J1, LDA, LDG, LDU1, LDU2, N, N1, N2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), U1(LDU1,*), + $ U2(LDU2,*) +C .. Local Scalars .. + LOGICAL LBLK + INTEGER IERR, J2, J3, J4, K, ND + DOUBLE PRECISION A11, A22, A33, CS, DNORM, EPS, SCALE, SMLNUM, + $ SN, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2, + $ WR1, WR2, XNORM +C .. Local Arrays .. + DOUBLE PRECISION D(LDD,4), V(3), V1(3), V2(3), X(LDX,2) +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DLANGE + EXTERNAL DDOT, DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL DAXPY, DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, + $ DLASET, DLASY2, DROT, DSCAL, DSWAP, DSYMV, + $ DSYR2, MB01MD, MB01ND +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C +C .. Executable Statements .. +C + INFO = 0 +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 ) + $ RETURN + LBLK = ( J1+N1.GT.N ) +C + J2 = J1 + 1 + J3 = J1 + 2 + J4 = J1 + 3 +C + IF ( LBLK .AND. N1.EQ.1 ) THEN +C + IF ( ISHAM ) THEN + A11 = A(N,N) + CALL DLARTG( G(N,N), -TWO*A11, CS, SN, TEMP ) + CALL DROT( N-1, A(1,N), 1, G(1,N), 1, CS, SN ) + A(N,N) = -A11 + IF ( WANTU ) + $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) + ELSE + CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) + CALL DSCAL( N-1, -ONE, A(1,N), 1 ) + IF ( WANTU ) THEN + CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) + CALL DSCAL( N, -ONE, U1(1,N), 1 ) + END IF + END IF +C + ELSE IF ( LBLK .AND. N1.EQ.2 ) THEN +C + IF ( ISHAM ) THEN +C +C Reorder Hamiltonian matrix: +C +C [ A11 G11 ] +C [ T ]. +C [ 0 -A11 ] +C + ND = 4 + CALL DLACPY( 'Full', 2, 2, A(N-1,N-1), LDA, D, LDD ) + CALL DLASET( 'All', 2, 2, ZERO, ZERO, D(3,1), LDD ) + CALL DLACPY( 'Upper', 2, 2, G(N-1,N-1), LDG, D(1,3), LDD ) + D(2,3) = D(1,4) + D(3,3) = -D(1,1) + D(4,3) = -D(1,2) + D(3,4) = -D(2,1) + D(4,4) = -D(2,2) + DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) +C +C Compute machine-dependent threshold for test for accepting +C swap. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + THRESH = MAX( FORTY*EPS*DNORM, SMLNUM ) +C +C Solve A11*X + X*A11' = scale*G11 for X. +C + CALL DLASY2( .FALSE., .FALSE., -1, 2, 2, D, LDD, D(3,3), + $ LDD, D(1,3), LDD, SCALE, X, LDX, XNORM, IERR ) +C +C Compute symplectic QR decomposition of +C +C ( -X11 -X12 ) +C ( -X21 -X22 ). +C ( scale 0 ) +C ( 0 scale ) +C + TEMP = -X(1,1) + CALL DLARTG( TEMP, SCALE, V1(1), V2(1), X(1,1) ) + CALL DLARTG( X(1,1), -X(2,1), V1(2), V2(2), TEMP ) + X(1,2) = -X(1,2) + X(2,2) = -X(2,2) + X(1,1) = ZERO + X(2,1) = SCALE + CALL DROT( 1, X(1,2), 1, X(1,1), 1, V1(1), V2(1) ) + CALL DROT( 1, X(1,2), 1, X(2,2), 1, V1(2), V2(2) ) + CALL DROT( 1, X(1,1), 1, X(2,1), 1, V1(2), V2(2) ) + CALL DLARTG( X(2,2), X(2,1), V1(3), V2(3), TEMP ) +C +C Perform swap provisionally on D. +C + CALL DROT( 4, D(1,1), LDD, D(3,1), LDD, V1(1), V2(1) ) + CALL DROT( 4, D(1,1), LDD, D(2,1), LDD, V1(2), V2(2) ) + CALL DROT( 4, D(3,1), LDD, D(4,1), LDD, V1(2), V2(2) ) + CALL DROT( 4, D(2,1), LDD, D(4,1), LDD, V1(3), V2(3) ) + CALL DROT( 4, D(1,1), 1, D(1,3), 1, V1(1), V2(1) ) + CALL DROT( 4, D(1,1), 1, D(1,2), 1, V1(2), V2(2) ) + CALL DROT( 4, D(1,3), 1, D(1,4), 1, V1(2), V2(2) ) + CALL DROT( 4, D(1,2), 1, D(1,4), 1, V1(3), V2(3) ) +C +C Test whether to reject swap. +C + IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), + $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 +C + CALL DLACPY( 'All', 2, 2, D(1,1), LDD, A(N-1,N-1), LDA ) + CALL DLACPY( 'Upper', 2, 2, D(1,3), LDD, G(N-1,N-1), LDG ) +C + IF ( N.GT.2 ) THEN + CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, V1(1), V2(1) ) + CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, V1(2), V2(2) ) + CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, V1(2), V2(2) ) + CALL DROT( N-2, A(1,N), 1, G(1,N), 1, V1(3), V2(3) ) + END IF +C + IF ( WANTU ) THEN + CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, V1(1), V2(1) ) + CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, V1(2), V2(2) ) + CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, V1(2), V2(2) ) + CALL DROT( N, U1(1,N), 1, U2(1,N), 1, V1(3), V2(3) ) + END IF +C + ELSE +C + IF ( ABS( A(N-1,N) ).GT.ABS( A(N,N-1) ) ) THEN + TEMP = G(N-1,N) + CALL DLARTG( TEMP, A(N-1,N), CS, SN, G(N-1,N) ) + SN = -SN + CALL DROT(N-2, A(1,N), 1, G(1,N), 1, CS, SN ) +C + A(N-1,N) = -SN*A(N,N-1) + TEMP = -CS*A(N,N-1) + A(N,N-1) = G(N-1,N) + G(N-1,N) = TEMP + IF ( WANTU ) + $ CALL DROT( N, U1(1,N), 1, U2(1,N), 1, CS, SN ) + CALL DSWAP( N-2, A(1,N-1), 1, G(1,N-1), 1 ) + CALL DSCAL( N-2, -ONE, A(1,N-1), 1 ) + IF ( WANTU ) THEN + CALL DSWAP( N, U1(1,N-1), 1, U2(1,N-1), 1 ) + CALL DSCAL( N, -ONE, U1(1,N-1), 1 ) + END IF + ELSE + TEMP = G(N-1,N) + CALL DLARTG( TEMP, A(N,N-1), CS, SN, G(N-1,N) ) + CALL DROT( N-2, A(1,N-1), 1, G(1,N-1), 1, CS, SN ) + A(N,N-1) = -SN*A(N-1,N) + A(N-1,N) = CS*A(N-1,N) + IF ( WANTU ) + $ CALL DROT( N, U1(1,N-1), 1, U2(1,N-1), 1, CS, SN ) + CALL DSWAP( N-1, A(1,N), 1, G(1,N), 1 ) + CALL DSCAL( N-1, -ONE, A(1,N), 1 ) + IF ( WANTU ) THEN + CALL DSWAP( N, U1(1,N), 1, U2(1,N), 1 ) + CALL DSCAL( N, -ONE, U1(1,N), 1 ) + END IF + END IF + END IF +C +C Standardize new 2-by-2 block. +C + CALL DLANV2( A(N-1,N-1), A(N-1,N), A(N,N-1), + $ A(N,N), WR1, WI1, WR2, WI2, CS, SN ) + CALL DROT( N-2, A(1,N-1), 1, A(1,N), 1, CS, SN ) + IF ( ISHAM ) THEN + TEMP = G(N-1,N) + CALL DROT( N-1, G(1,N-1), 1, G(1,N), 1, CS, SN ) + TAU = CS*TEMP + SN*G(N,N) + G(N,N) = CS*G(N,N) - SN*TEMP + G(N-1,N-1) = CS*G(N-1,N-1) + SN*TAU + CALL DROT( 1, G(N-1,N), LDG, G(N,N), LDG, CS, SN ) + ELSE + CALL DROT( N-2, G(1,N-1), 1, G(1,N), 1, CS, SN ) + END IF + IF ( WANTU ) THEN + CALL DROT( N, U1(1,N-1), 1, U1(1,N), 1, CS, SN ) + CALL DROT( N, U2(1,N-1), 1, U2(1,N), 1, CS, SN ) + END IF +C + ELSE IF ( N1.EQ.1 .AND. N2.EQ.1 ) THEN +C +C Swap two 1-by-1 blocks. +C + A11 = A(J1,J1) + A22 = A(J2,J2) +C +C Determine the transformation to perform the interchange. +C + CALL DLARTG( A(J1,J2), A22-A11, CS, SN, TEMP ) +C +C Apply transformation to the matrix A. +C + IF ( J3.LE.N ) + $ CALL DROT( N-J1-1, A(J1,J3), LDA, A(J2,J3), LDA, CS, SN ) + CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) +C + A(J1,J1) = A22 + A(J2,J2) = A11 +C +C Apply transformation to the matrix G. +C + IF ( ISHAM ) THEN + TEMP = G(J1,J2) + CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) + TAU = CS*TEMP + SN*G(J2,J2) + G(J2,J2) = CS*G(J2,J2) - SN*TEMP + G(J1,J1) = CS*G(J1,J1) + SN*TAU + CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) + ELSE + IF ( N.GT.J1+1 ) + $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, CS, + $ SN ) + CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) + END IF + IF ( WANTU ) THEN +C +C Accumulate transformation in the matrices U1 and U2. +C + CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) + CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) + END IF +C + ELSE +C +C Swapping involves at least one 2-by-2 block. +C +C Copy the diagonal block of order N1+N2 to the local array D +C and compute its norm. +C + ND = N1 + N2 + CALL DLACPY( 'Full', ND, ND, A(J1,J1), LDA, D, LDD ) + DNORM = DLANGE( 'Max', ND, ND, D, LDD, DWORK ) +C +C Compute machine-dependent threshold for test for accepting +C swap. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + THRESH = MAX( THIRTY*EPS*DNORM, SMLNUM ) +C +C Solve A11*X - X*A22 = scale*A12 for X. +C + CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD, + $ D(N1+1,N1+1), LDD, D(1,N1+1), LDD, SCALE, X, LDX, + $ XNORM, IERR ) +C +C Swap the adjacent diagonal blocks. +C + K = N1 + N1 + N2 - 3 + GO TO ( 10, 20, 30 )K +C + 10 CONTINUE +C +C N1 = 1, N2 = 2: generate elementary reflector H so that: +C +C ( scale, X11, X12 ) H = ( 0, 0, * ). +C + V(1) = SCALE + V(2) = X(1,1) + V(3) = X(1,2) + CALL DLARFG( 3, V(3), V, 1, TAU ) + V(3) = ONE + A11 = A(J1,J1) +C +C Perform swap provisionally on diagonal block in D. +C + CALL DLARFX( 'Left', 3, 3, V, TAU, D, LDD, DWORK ) + CALL DLARFX( 'Right', 3, 3, V, TAU, D, LDD, DWORK ) +C +C Test whether to reject swap. +C + IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(3,3)-A11 ) ) + $ .GT.THRESH ) GO TO 50 +C +C Accept swap: apply transformation to the entire matrix A. +C + CALL DLARFX( 'Left', 3, N-J1+1, V, TAU, A(J1,J1), LDA, DWORK ) + CALL DLARFX( 'Right', J2, 3, V, TAU, A(1,J1), LDA, DWORK ) +C + A(J3,J1) = ZERO + A(J3,J2) = ZERO + A(J3,J3) = A11 +C +C Apply transformation to G. +C + IF ( ISHAM ) THEN + CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) + CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, + $ DWORK, 1 ) + TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) + CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) + CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, + $ G(J1,J1), LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, + $ DWORK ) + ELSE + CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) + CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, + $ DWORK, 1 ) + CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), + $ LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, + $ DWORK ) + END IF +C + IF ( WANTU ) THEN +C +C Accumulate transformation in the matrices U1 and U2. +C + CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) + CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) + END IF + GO TO 40 +C + 20 CONTINUE +C +C N1 = 2, N2 = 1: generate elementary reflector H so that: +C +C H ( -X11 ) = ( * ) +C ( -X21 ) = ( 0 ). +C ( scale ) = ( 0 ) +C + V(1) = -X(1,1) + V(2) = -X(2,1) + V(3) = SCALE + CALL DLARFG( 3, V(1), V(2), 1, TAU ) + V(1) = ONE + A33 = A(J3,J3) +C +C Perform swap provisionally on diagonal block in D. +C + CALL DLARFX( 'L', 3, 3, V, TAU, D, LDD, DWORK ) + CALL DLARFX( 'R', 3, 3, V, TAU, D, LDD, DWORK ) +C +C Test whether to reject swap. +C + IF ( MAX( ABS( D(2,1) ), ABS( D(3,1) ), ABS( D(1,1)-A33 ) ) + $ .GT. THRESH ) GO TO 50 +C +C Accept swap: apply transformation to the entire matrix A. +C + CALL DLARFX( 'Right', J3, 3, V, TAU, A(1,J1), LDA, DWORK ) + CALL DLARFX( 'Left', 3, N-J1, V, TAU, A(J1,J2), LDA, DWORK ) +C + A(J1,J1) = A33 + A(J2,J1) = ZERO + A(J3,J1) = ZERO +C +C Apply transformation to G. +C + IF ( ISHAM ) THEN + CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) + CALL DSYMV( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, + $ DWORK, 1 ) + TEMP = -HALF*TAU*DDOT( 3, DWORK, 1, V, 1 ) + CALL DAXPY( 3, TEMP, V, 1, DWORK, 1 ) + CALL DSYR2( 'Upper', 3, -ONE, V, 1, DWORK, 1, G(J1,J1), + $ LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, + $ DWORK ) + ELSE + CALL DLARFX( 'Right', J1-1, 3, V, TAU, G(1,J1), LDG, DWORK ) + CALL MB01MD( 'Upper', 3, TAU, G(J1,J1), LDG, V, 1, ZERO, + $ DWORK, 1 ) + CALL MB01ND( 'Upper', 3, ONE, V, 1, DWORK, 1, G(J1,J1), + $ LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V, TAU, G(J1,J1+3), LDG, + $ DWORK ) + END IF +C + IF ( WANTU ) THEN +C +C Accumulate transformation in the matrices U1 and U2. +C + CALL DLARFX( 'R', N, 3, V, TAU, U1(1,J1), LDU1, DWORK ) + CALL DLARFX( 'R', N, 3, V, TAU, U2(1,J1), LDU2, DWORK ) + END IF + GO TO 40 +C + 30 CONTINUE +C +C N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so +C that: +C +C H(2) H(1) ( -X11 -X12 ) = ( * * ) +C ( -X21 -X22 ) ( 0 * ). +C ( scale 0 ) ( 0 0 ) +C ( 0 scale ) ( 0 0 ) +C + V1(1) = -X(1,1) + V1(2) = -X(2,1) + V1(3) = SCALE + CALL DLARFG( 3, V1(1), V1(2), 1, TAU1 ) + V1(1) = ONE +C + TEMP = -TAU1*( X(1,2)+V1(2)*X(2,2) ) + V2(1) = -TEMP*V1(2) - X(2,2) + V2(2) = -TEMP*V1(3) + V2(3) = SCALE + CALL DLARFG( 3, V2(1), V2(2), 1, TAU2 ) + V2(1) = ONE +C +C Perform swap provisionally on diagonal block in D. +C + CALL DLARFX( 'L', 3, 4, V1, TAU1, D, LDD, DWORK ) + CALL DLARFX( 'R', 4, 3, V1, TAU1, D, LDD, DWORK ) + CALL DLARFX( 'L', 3, 4, V2, TAU2, D(2,1), LDD, DWORK ) + CALL DLARFX( 'R', 4, 3, V2, TAU2, D(1,2), LDD, DWORK ) +C +C Test whether to reject swap. +C + IF ( MAX( ABS( D(3,1) ), ABS( D(3,2) ), ABS( D(4,1) ), + $ ABS( D(4,2) ) ).GT.THRESH ) GO TO 50 +C +C Accept swap: apply transformation to the entire matrix A. +C + CALL DLARFX( 'L', 3, N-J1+1, V1, TAU1, A(J1,J1), LDA, DWORK ) + CALL DLARFX( 'R', J4, 3, V1, TAU1, A(1,J1), LDA, DWORK ) + CALL DLARFX( 'L', 3, N-J1+1, V2, TAU2, A(J2,J1), LDA, DWORK ) + CALL DLARFX( 'R', J4, 3, V2, TAU2, A(1,J2), LDA, DWORK ) +C + A(J3,J1) = ZERO + A(J3,J2) = ZERO + A(J4,J1) = ZERO + A(J4,J2) = ZERO +C +C Apply transformation to G. +C + IF ( ISHAM ) THEN + CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, + $ DWORK ) + CALL DSYMV( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, + $ DWORK, 1 ) + TEMP = -HALF*TAU1*DDOT( 3, DWORK, 1, V1, 1 ) + CALL DAXPY( 3, TEMP, V1, 1, DWORK, 1 ) + CALL DSYR2( 'Upper', 3, -ONE, V1, 1, DWORK, 1, + $ G(J1,J1), LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), + $ LDG, DWORK ) +C + CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, + $ DWORK ) + CALL DSYMV( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, + $ DWORK, 1 ) + TEMP = -HALF*TAU2*DDOT( 3, DWORK, 1, V2, 1 ) + CALL DAXPY( 3, TEMP, V2, 1, DWORK, 1 ) + CALL DSYR2( 'Upper', 3, -ONE, V2, 1, DWORK, 1, G(J2,J2), + $ LDG ) + IF ( N.GT.J2+2 ) + $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), + $ LDG, DWORK ) + ELSE + CALL DLARFX( 'Right', J1-1, 3, V1, TAU1, G(1,J1), LDG, + $ DWORK ) + CALL MB01MD( 'Upper', 3, TAU1, G(J1,J1), LDG, V1, 1, ZERO, + $ DWORK, 1 ) + CALL MB01ND( 'Upper', 3, ONE, V1, 1, DWORK, 1, G(J1,J1), + $ LDG ) + IF ( N.GT.J1+2 ) + $ CALL DLARFX( 'Left', 3, N-J1-2, V1, TAU1, G(J1,J1+3), + $ LDG, DWORK ) + CALL DLARFX( 'Right', J2-1, 3, V2, TAU2, G(1,J2), LDG, + $ DWORK ) + CALL MB01MD( 'Upper', 3, TAU2, G(J2,J2), LDG, V2, 1, ZERO, + $ DWORK, 1 ) + CALL MB01ND( 'Upper', 3, ONE, V2, 1, DWORK, 1, G(J2,J2), + $ LDG ) + IF ( N.GT.J2+2 ) + $ CALL DLARFX( 'Left', 3, N-J2-2, V2, TAU2, G(J2,J2+3), + $ LDG, DWORK ) + END IF +C + IF ( WANTU ) THEN +C +C Accumulate transformation in the matrices U1 and U2. +C + CALL DLARFX( 'R', N, 3, V1, TAU1, U1(1,J1), LDU1, DWORK ) + CALL DLARFX( 'R', N, 3, V2, TAU2, U1(1,J2), LDU1, DWORK ) + CALL DLARFX( 'R', N, 3, V1, TAU1, U2(1,J1), LDU2, DWORK ) + CALL DLARFX( 'R', N, 3, V2, TAU2, U2(1,J2), LDU2, DWORK ) + END IF +C + 40 CONTINUE +C + IF ( N2.EQ.2 ) THEN +C +C Standardize new 2-by-2 block A11. +C + CALL DLANV2( A(J1,J1), A(J1,J2), A(J2,J1), A(J2,J2), WR1, + $ WI1, WR2, WI2, CS, SN ) + CALL DROT( N-J1-1, A(J1,J1+2), LDA, A(J2,J1+2), LDA, CS, + $ SN ) + CALL DROT( J1-1, A(1,J1), 1, A(1,J2), 1, CS, SN ) + IF ( ISHAM ) THEN + TEMP = G(J1,J2) + CALL DROT( J1, G(1,J1), 1, G(1,J2), 1, CS, SN ) + TAU = CS*TEMP + SN*G(J2,J2) + G(J2,J2) = CS*G(J2,J2) - SN*TEMP + G(J1,J1) = CS*G(J1,J1) + SN*TAU + CALL DROT( N-J1, G(J1,J2), LDG, G(J2,J2), LDG, CS, SN ) + ELSE + IF ( N.GT.J1+1 ) + $ CALL DROT( N-J1-1, G(J1,J1+2), LDG, G(J2,J1+2), LDG, + $ CS, SN ) + CALL DROT( J1-1, G(1,J1), 1, G(1,J2), 1, CS, SN ) + END IF + IF ( WANTU ) THEN + CALL DROT( N, U1(1,J1), 1, U1(1,J2), 1, CS, SN ) + CALL DROT( N, U2(1,J1), 1, U2(1,J2), 1, CS, SN ) + END IF + END IF +C + IF ( N1.EQ.2 ) THEN +C +C Standardize new 2-by-2 block A22. +C + J3 = J1 + N2 + J4 = J3 + 1 + CALL DLANV2( A(J3,J3), A(J3,J4), A(J4,J3), A(J4,J4), WR1, + $ WI1, WR2, WI2, CS, SN ) + IF ( J3+2.LE.N ) + $ CALL DROT( N-J3-1, A(J3,J3+2), LDA, A(J4,J3+2), LDA, CS, + $ SN ) + CALL DROT( J3-1, A(1,J3), 1, A(1,J4), 1, CS, SN ) + IF ( ISHAM ) THEN + TEMP = G(J3,J4) + CALL DROT( J3, G(1,J3), 1, G(1,J4), 1, CS, SN ) + TAU = CS*TEMP + SN*G(J4,J4) + G(J4,J4) = CS*G(J4,J4) - SN*TEMP + G(J3,J3) = CS*G(J3,J3) + SN*TAU + CALL DROT( N-J3, G(J3,J4), LDG, G(J4,J4), LDG, CS, SN ) + ELSE + IF ( N.GT.J3+1 ) + $ CALL DROT( N-J3-1, G(J3,J3+2), LDG, G(J4,J3+2), LDG, + $ CS, SN ) + CALL DROT( J3-1, G(1,J3), 1, G(1,J4), 1, CS, SN ) + END IF + IF ( WANTU ) THEN + CALL DROT( N, U1(1,J3), 1, U1(1,J4), 1, CS, SN ) + CALL DROT( N, U2(1,J3), 1, U2(1,J4), 1, CS, SN ) + END IF + END IF +C + END IF + RETURN +C +C Exit with INFO = 1 if swap was rejected. +C + 50 CONTINUE + INFO = 1 + RETURN +C *** Last line of MB03TS *** + END diff --git a/mex/sources/libslicot/MB03UD.f b/mex/sources/libslicot/MB03UD.f new file mode 100644 index 000000000..37e6b6bcd --- /dev/null +++ b/mex/sources/libslicot/MB03UD.f @@ -0,0 +1,318 @@ + SUBROUTINE MB03UD( JOBQ, JOBP, N, A, LDA, Q, LDQ, SV, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute all, or part, of the singular value decomposition of a +C real upper triangular matrix. +C +C The N-by-N upper triangular matrix A is factored as A = Q*S*P', +C where Q and P are N-by-N orthogonal matrices and S is an +C N-by-N diagonal matrix with non-negative diagonal elements, +C SV(1), SV(2), ..., SV(N), ordered such that +C +C SV(1) >= SV(2) >= ... >= SV(N) >= 0. +C +C The columns of Q are the left singular vectors of A, the diagonal +C elements of S are the singular values of A and the columns of P +C are the right singular vectors of A. +C +C Either or both of Q and P' may be requested. +C When P' is computed, it is returned in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBQ CHARACTER*1 +C Specifies whether the user wishes to compute the matrix Q +C of left singular vectors as follows: +C = 'V': Left singular vectors are computed; +C = 'N': No left singular vectors are computed. +C +C JOBP CHARACTER*1 +C Specifies whether the user wishes to compute the matrix P' +C of right singular vectors as follows: +C = 'V': Right singular vectors are computed; +C = 'N': No right singular vectors are computed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix A. +C On exit, if JOBP = 'V', the leading N-by-N part of this +C array contains the N-by-N orthogonal matrix P'; otherwise +C the N-by-N upper triangular part of A is used as internal +C workspace. The strictly lower triangular part of A is set +C internally to zero before the reduction to bidiagonal form +C is performed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C If JOBQ = 'V', the leading N-by-N part of this array +C contains the orthogonal matrix Q. +C If JOBQ = 'N', Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, and when JOBQ = 'V', LDQ >= MAX(1,N). +C +C SV (output) DOUBLE PRECISION array, dimension (N) +C The N singular values of the matrix A, sorted in +C descending order. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK; +C if INFO > 0, DWORK(2:N) contains the unconverged +C superdiagonal elements of an upper bidiagonal matrix B +C whose diagonal is in SV (not necessarily sorted). +C B satisfies A = Q*B*P', so it has the same singular +C values as A, and singular vectors related by Q and P'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,5*N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: the QR algorithm has failed to converge. In this +C case INFO specifies how many superdiagonals did not +C converge (see the description of DWORK). +C This failure is not likely to occur. +C +C METHOD +C +C The routine reduces A to bidiagonal form by means of elementary +C reflectors and then uses the QR algorithm on the bidiagonal form. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute of Informatics, Bucharest, and +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen, +C March 1998. Based on the RASP routine DTRSVD. +C +C REVISIONS +C +C V. Sima, Feb. 2000. +C +C KEYWORDS +C +C Bidiagonalization, orthogonal transformation, singular value +C decomposition, singular values, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBP, JOBQ + INTEGER INFO, LDA, LDQ, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), Q(LDQ,*), SV(*) +C .. Local Scalars .. + LOGICAL WANTQ, WANTP + INTEGER I, IE, ISCL, ITAUP, ITAUQ, JWORK, MAXWRK, + $ MINWRK, NCOLP, NCOLQ + DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANTR + EXTERNAL DLAMCH, DLANTR, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DBDSQR, DGEBRD, DLACPY, DLASCL, DLASET, DORGBR, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +C .. Executable Statements .. +C +C Check the input scalar arguments. +C + INFO = 0 + WANTQ = LSAME( JOBQ, 'V' ) + WANTP = LSAME( JOBP, 'V' ) + MINWRK = 1 + IF( .NOT.WANTQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTP .AND. .NOT.LSAME( JOBP, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.WANTQ .AND. LDQ.LT.1 ) ) THEN + INFO = -7 + END IF +C +C Compute workspace +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately following +C subroutine, as returned by ILAENV.) +C + IF( INFO.EQ.0 .AND. LDWORK.GE.1 .AND. N.GT.0 ) THEN + MAXWRK = 3*N+2*N*ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) + IF( WANTQ ) + $ MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) ) + IF( WANTP ) + $ MAXWRK = MAX( MAXWRK, 3*N+N* + $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) + MINWRK = 5*N + MAXWRK = MAX( MAXWRK, MINWRK ) + DWORK(1) = MAXWRK + END IF +C + IF( LDWORK.LT.MINWRK ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Get machine constants. +C + EPS = DLAMCH( 'P' ) + SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS + BIGNUM = ONE / SMLNUM +C +C Scale A if max entry outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANTR( 'Max', 'Upper', 'Non-unit', N, N, A, LDA, DUM ) + ISCL = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ISCL = 1 + CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, N, N, A, LDA, INFO ) + ELSE IF( ANRM.GT.BIGNUM ) THEN + ISCL = 1 + CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, N, N, A, LDA, INFO ) + END IF +C +C Zero out below. +C + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, A(2,1), LDA ) +C +C Find the singular values and optionally the singular vectors +C of the upper triangular matrix A. +C + IE = 1 + ITAUQ = IE + N + ITAUP = ITAUQ + N + JWORK = ITAUP + N +C +C First reduce the matrix to bidiagonal form. The diagonal +C elements will be in SV and the superdiagonals in DWORK(IE). +C (Workspace: need 4*N, prefer 3*N+2*N*NB) +C + CALL DGEBRD( N, N, A, LDA, SV, DWORK(IE), DWORK(ITAUQ), + $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) + IF( WANTQ ) THEN +C +C Generate the transformation matrix Q corresponding to the +C left singular vectors. +C (Workspace: need 4*N, prefer 3*N+N*NB) +C + NCOLQ = N + CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) + CALL DORGBR( 'Q', N, N, N, Q, LDQ, DWORK(ITAUQ), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + ELSE + NCOLQ = 0 + END IF + IF( WANTP ) THEN +C +C Generate the transformation matrix P' corresponding to the +C right singular vectors. +C (Workspace: need 4*N, prefer 3*N+N*NB) +C + NCOLP = N + CALL DORGBR( 'P', N, N, N, A, LDA, DWORK(ITAUP), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + ELSE + NCOLP = 0 + END IF + JWORK = IE + N +C +C Perform bidiagonal QR iteration, to obtain all or part of the +C singular value decomposition of A. +C (Workspace: need 5*N) +C + CALL DBDSQR( 'U', N, NCOLP, NCOLQ, 0, SV, DWORK(IE), A, LDA, + $ Q, LDQ, DUM, 1, DWORK(JWORK), INFO ) +C +C If DBDSQR failed to converge, copy unconverged superdiagonals +C to DWORK(2:N). +C + IF( INFO.NE.0 ) THEN + DO 10 I = N - 1, 1, -1 + DWORK(I+1) = DWORK(I+IE-1) + 10 CONTINUE + END IF +C +C Undo scaling if necessary. +C + IF( ISCL.EQ.1 ) THEN + IF( ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N, 1, SV, N, INFO ) + IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM ) + $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, N-1, 1, DWORK(2), N, + $ INFO ) + IF( ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N, 1, SV, N, INFO ) + IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM ) + $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, N-1, 1, DWORK(2), N, + $ INFO ) + END IF +C +C Return optimal workspace in DWORK(1). +C + DWORK(1) = MAXWRK +C + RETURN +C *** Last line of MB03UD *** + END diff --git a/mex/sources/libslicot/MB03VD.f b/mex/sources/libslicot/MB03VD.f new file mode 100644 index 000000000..4cf99f6fb --- /dev/null +++ b/mex/sources/libslicot/MB03VD.f @@ -0,0 +1,306 @@ + SUBROUTINE MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a product of p real general matrices A = A_1*A_2*...*A_p +C to upper Hessenberg form, H = H_1*H_2*...*H_p, where H_1 is +C upper Hessenberg, and H_2, ..., H_p are upper triangular, by using +C orthogonal similarity transformations on A, +C +C Q_1' * A_1 * Q_2 = H_1, +C Q_2' * A_2 * Q_3 = H_2, +C ... +C Q_p' * A_p * Q_1 = H_p. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the square matrices A_1, A_2, ..., A_p. +C N >= 0. +C +C P (input) INTEGER +C The number of matrices in the product A_1*A_2*...*A_p. +C P >= 1. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that all matrices A_j, j = 2, ..., p, are +C already upper triangular in rows and columns 1:ILO-1 and +C IHI+1:N, and A_1 is upper Hessenberg in rows and columns +C 1:ILO-1 and IHI+1:N, with A_1(ILO,ILO-1) = 0 (unless +C ILO = 1), and A_1(IHI+1,IHI) = 0 (unless IHI = N). +C If this is not the case, ILO and IHI should be set to 1 +C and N, respectively. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA1,LDA2,P) +C On entry, the leading N-by-N-by-P part of this array must +C contain the matrices of factors to be reduced; +C specifically, A(*,*,j) must contain A_j, j = 1, ..., p. +C On exit, the leading N-by-N upper triangle and the first +C subdiagonal of A(*,*,1) contain the upper Hessenberg +C matrix H_1, and the elements below the first subdiagonal, +C with the first column of the array TAU represent the +C orthogonal matrix Q_1 as a product of elementary +C reflectors. See FURTHER COMMENTS. +C For j > 1, the leading N-by-N upper triangle of A(*,*,j) +C contains the upper triangular matrix H_j, and the elements +C below the diagonal, with the j-th column of the array TAU +C represent the orthogonal matrix Q_j as a product of +C elementary reflectors. See FURTHER COMMENTS. +C +C LDA1 INTEGER +C The first leading dimension of the array A. +C LDA1 >= max(1,N). +C +C LDA2 INTEGER +C The second leading dimension of the array A. +C LDA2 >= max(1,N). +C +C TAU (output) DOUBLE PRECISION array, dimension (LDTAU,P) +C The leading N-1 elements in the j-th column contain the +C scalar factors of the elementary reflectors used to form +C the matrix Q_j, j = 1, ..., P. See FURTHER COMMENTS. +C +C LDTAU INTEGER +C The leading dimension of the array TAU. +C LDTAU >= max(1,N-1). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The algorithm consists in ihi-ilo major steps. In each such +C step i, ilo <= i <= ihi-1, the subdiagonal elements in the i-th +C column of A_j are annihilated using a Householder transformation +C from the left, which is also applied to A_(j-1) from the right, +C for j = p:-1:2. Then, the elements below the subdiagonal of the +C i-th column of A_1 are annihilated, and the Householder +C transformation is also applied to A_p from the right. +C See FURTHER COMMENTS. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. +C The periodic Schur decomposition: algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Sreedhar, J. and Van Dooren, P. +C Periodic Schur form and some matrix equations. +C Proc. of the Symposium on the Mathematical Theory of Networks +C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, +C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C FURTHER COMMENTS +C +C Each matrix Q_j is represented as a product of (ihi-ilo) +C elementary reflectors, +C +C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). +C +C Each H_j(i), i = ilo, ..., ihi-1, has the form +C +C H_j(i) = I - tau_j * v_j * v_j', +C +C where tau_j is a real scalar, and v_j is a real vector with +C v_j(1:i) = 0, v_j(i+1) = 1 and v_j(ihi+1:n) = 0; v_j(i+2:ihi) +C is stored on exit in A_j(i+2:ihi,i), and tau_j in TAU(i,j). +C +C The contents of A_1 are illustrated by the following example +C for n = 7, ilo = 2, and ihi = 6: +C +C on entry on exit +C +C ( a a a a a a a ) ( a h h h h h a ) +C ( 0 a a a a a a ) ( 0 h h h h h a ) +C ( 0 a a a a a a ) ( 0 h h h h h h ) +C ( 0 a a a a a a ) ( 0 v2 h h h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) +C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) +C +C where a denotes an element of the original matrix A_1, h denotes +C a modified element of the upper Hessenberg matrix H_1, and vi +C denotes an element of the vector defining H_1(i). +C +C The contents of A_j, j > 1, are illustrated by the following +C example for n = 7, ilo = 2, and ihi = 6: +C +C on entry on exit +C +C ( a a a a a a a ) ( a h h h h h a ) +C ( 0 a a a a a a ) ( 0 h h h h h h ) +C ( 0 a a a a a a ) ( 0 v2 h h h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 h h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 v4 h h h ) +C ( 0 a a a a a a ) ( 0 v2 v3 v4 v5 h h ) +C ( 0 0 0 0 0 0 a ) ( 0 0 0 0 0 0 a ) +C +C where a denotes an element of the original matrix A_j, h denotes +C a modified element of the upper triangular matrix H_j, and vi +C denotes an element of the vector defining H_j(i). (The element +C (1,2) in A_p is also unchanged for this example.) +C +C Note that for P = 1, the LAPACK Library routine DGEHRD could be +C more efficient on some computer architectures than this routine +C (a BLAS 2 version). +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, +C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. +C Partly based on the routine PSHESS by A. Varga +C (DLR Oberpfaffenhofen), November 26, 1995. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, periodic systems, +C similarity transformation, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) +C .. +C .. Local Scalars .. + INTEGER I, I1, I2, J, NH +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUMMY( 1 ) +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DLARFG, MB04PY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( P.LT.1 ) THEN + INFO = -2 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -4 + ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03VD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NH = IHI - ILO + 1 + IF ( NH.LE.1 ) + $ RETURN +C + DUMMY( 1 ) = ZERO +C + DO 20 I = ILO, IHI - 1 + I1 = I + 1 + I2 = MIN( I+2, N ) +C + DO 10 J = P, 2, -1 +C +C Set the elements 1:ILO-1 and IHI:N-1 of TAU(*,J) to zero. +C + CALL DCOPY( ILO-1, DUMMY, 0, TAU( 1, J ), 1 ) + IF ( IHI.LT.N ) + $ CALL DCOPY( N-IHI, DUMMY, 0, TAU( IHI, J ), 1 ) +C +C Compute elementary reflector H_j(i) to annihilate +C A_j(i+1:ihi,i). +C + CALL DLARFG( IHI-I+1, A( I, I, J ), A( I1, I, J ), 1, + $ TAU( I, J ) ) +C +C Apply H_j(i) to A_(j-1)(1:ihi,i:ihi) from the right. +C + CALL MB04PY( 'Right', IHI, IHI-I+1, A( I1, I, J ), + $ TAU( I, J ), A( 1, I, J-1 ), LDA1, DWORK ) +C +C Apply H_j(i) to A_j(i:ihi,i+1:n) from the left. +C + CALL MB04PY( 'Left', IHI-I+1, N-I, A( I1, I, J ), + $ TAU( I, J ), A( I, I1, J ), LDA1, DWORK ) + 10 CONTINUE +C +C Compute elementary reflector H_1(i) to annihilate +C A_1(i+2:ihi,i). +C + CALL DLARFG( IHI-I, A( I1, I, 1 ), A( I2, I, 1 ), 1, + $ TAU( I, 1 ) ) +C +C Apply H_1(i) to A_p(1:ihi,i+1:ihi) from the right. +C + CALL MB04PY( 'Right', IHI, IHI-I, A( I2, I, 1 ), TAU( I, 1 ), + $ A( 1, I1, P ), LDA1, DWORK ) +C +C Apply H_1(i) to A_1(i+1:ihi,i+1:n) from the left. +C + CALL MB04PY( 'Left', IHI-I, N-I, A( I2, I, 1 ), TAU( I, 1 ), + $ A( I1, I1, 1 ), LDA1, DWORK ) + 20 CONTINUE +C + RETURN +C +C *** Last line of MB03VD *** + END diff --git a/mex/sources/libslicot/MB03VY.f b/mex/sources/libslicot/MB03VY.f new file mode 100644 index 000000000..163e77497 --- /dev/null +++ b/mex/sources/libslicot/MB03VY.f @@ -0,0 +1,216 @@ + SUBROUTINE MB03VY( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate the real orthogonal matrices Q_1, Q_2, ..., Q_p, +C which are defined as the product of ihi-ilo elementary reflectors +C of order n, as returned by SLICOT Library routine MB03VD: +C +C Q_j = H_j(ilo) H_j(ilo+1) . . . H_j(ihi-1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices Q_1, Q_2, ..., Q_p. N >= 0. +C +C P (input) INTEGER +C The number p of transformation matrices. P >= 1. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C The values of the indices ilo and ihi, respectively, used +C in the previous call of the SLICOT Library routine MB03VD. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA1,LDA2,N) +C On entry, the leading N-by-N strictly lower triangular +C part of A(*,*,j) must contain the vectors which define the +C elementary reflectors used for reducing A_j, as returned +C by SLICOT Library routine MB03VD, j = 1, ..., p. +C On exit, the leading N-by-N part of A(*,*,j) contains the +C N-by-N orthogonal matrix Q_j, j = 1, ..., p. +C +C LDA1 INTEGER +C The first leading dimension of the array A. +C LDA1 >= max(1,N). +C +C LDA2 INTEGER +C The second leading dimension of the array A. +C LDA2 >= max(1,N). +C +C TAU (input) DOUBLE PRECISION array, dimension (LDTAU,P) +C The leading N-1 elements in the j-th column must contain +C the scalar factors of the elementary reflectors used to +C form the matrix Q_j, as returned by SLICOT Library routine +C MB03VD. +C +C LDTAU INTEGER +C The leading dimension of the array TAU. +C LDTAU >= max(1,N-1). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Each matrix Q_j is generated as the product of the elementary +C reflectors used for reducing A_j. Standard LAPACK routines for +C Hessenberg and QR decompositions are used. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. +C The periodic Schur decomposition: algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Sreedhar, J. and Van Dooren, P. +C Periodic Schur form and some matrix equations. +C Proc. of the Symposium on the Mathematical Theory of Networks +C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, +C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, +C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. +C Partly based on the routine PSHTR by A. Varga +C (DLR Oberpfaffenhofen), November 26, 1995. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, periodic systems, +C similarity transformation, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C +C .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA1, LDA2, LDTAU, LDWORK, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA1, LDA2, * ), DWORK( * ), TAU( LDTAU, * ) +C .. +C .. Local Scalars .. + INTEGER J, NH + DOUBLE PRECISION WRKOPT +C .. +C .. External Subroutines .. + EXTERNAL DLASET, DORGHR, DORGQR, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( P.LT.1 ) THEN + INFO = -2 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -4 + ELSE IF( LDA1.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDA2.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDTAU.LT.MAX( 1, N-1 ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03VY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Generate the orthogonal matrix Q_1. +C + CALL DORGHR( N, ILO, IHI, A, LDA1, TAU, DWORK, LDWORK, INFO ) + WRKOPT = DWORK( 1 ) +C + NH = IHI - ILO + 1 +C + DO 20 J = 2, P +C +C Generate the orthogonal matrix Q_j. +C Set the first ILO-1 and the last N-IHI rows and columns of Q_j +C to those of the unit matrix. +C + CALL DLASET( 'Full', N, ILO-1, ZERO, ONE, A( 1, 1, J ), LDA1 ) + CALL DLASET( 'Full', ILO-1, NH, ZERO, ZERO, A( 1, ILO, J ), + $ LDA1 ) + IF ( NH.GT.1 ) + $ CALL DORGQR( NH, NH, NH-1, A( ILO, ILO, J ), LDA1, + $ TAU( ILO, J ), DWORK, LDWORK, INFO ) + IF ( IHI.LT.N ) THEN + CALL DLASET( 'Full', N-IHI, NH, ZERO, ZERO, + $ A( IHI+1, ILO, J ), LDA1 ) + CALL DLASET( 'Full', IHI, N-IHI, ZERO, ZERO, + $ A( 1, IHI+1, J ), LDA1 ) + CALL DLASET( 'Full', N-IHI, N-IHI, ZERO, ONE, + $ A( IHI+1, IHI+1, J ), LDA1 ) + END IF + 20 CONTINUE +C + DWORK( 1 ) = MAX( WRKOPT, DWORK( 1 ) ) + RETURN +C +C *** Last line of MB03VY *** + END diff --git a/mex/sources/libslicot/MB03WA.f b/mex/sources/libslicot/MB03WA.f new file mode 100644 index 000000000..0a800ae0c --- /dev/null +++ b/mex/sources/libslicot/MB03WA.f @@ -0,0 +1,538 @@ + SUBROUTINE MB03WA( WANTQ, WANTZ, N1, N2, A, LDA, B, LDB, Q, LDQ, + $ Z, LDZ, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To swap adjacent diagonal blocks A11*B11 and A22*B22 of size +C 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix product +C A*B by an orthogonal equivalence transformation. +C +C (A, B) must be in periodic real Schur canonical form (as returned +C by SLICOT Library routine MB03XP), i.e., A is block upper +C triangular with 1-by-1 and 2-by-2 diagonal blocks, and B is upper +C triangular. +C +C Optionally, the matrices Q and Z of generalized Schur vectors are +C updated. +C +C Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)', +C Z(in) * B(in) * Q(in)' = Z(out) * B(out) * Q(out)'. +C +C This routine is largely based on the LAPACK routine DTGEX2 +C developed by Bo Kagstrom and Peter Poromaa. +C +C ARGUMENTS +C +C Mode Parameters +C +C WANTQ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Q as follows: +C = .TRUE. : The matrix Q is updated; +C = .FALSE.: the matrix Q is not required. +C +C WANTZ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Z as follows: +C = .TRUE. : The matrix Z is updated; +C = .FALSE.: the matrix Z is not required. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The order of the first block A11*B11. N1 = 0, 1 or 2. +C +C N2 (input) INTEGER +C The order of the second block A22*B22. N2 = 0, 1 or 2. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,N1+N2) +C On entry, the leading (N1+N2)-by-(N1+N2) part of this +C array must contain the matrix A. +C On exit, the leading (N1+N2)-by-(N1+N2) part of this array +C contains the matrix A of the reordered pair. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N1+N2). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,N1+N2) +C On entry, the leading (N1+N2)-by-(N1+N2) part of this +C array must contain the matrix B. +C On exit, the leading (N1+N2)-by-(N1+N2) part of this array +C contains the matrix B of the reordered pair. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N1+N2). +C +C Q (input/output) DOUBLE PRECISION array, dimension +C (LDQ,N1+N2) +C On entry, if WANTQ = .TRUE., the leading +C (N1+N2)-by-(N1+N2) part of this array must contain the +C orthogonal matrix Q. +C On exit, the leading (N1+N2)-by-(N1+N2) part of this array +C contains the updated matrix Q. Q will be a rotation +C matrix for N1=N2=1. +C This array is not referenced if WANTQ = .FALSE.. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= 1. +C If WANTQ = .TRUE., LDQ >= N1+N2. +C +C Z (input/output) DOUBLE PRECISION array, dimension +C (LDZ,N1+N2) +C On entry, if WANTZ = .TRUE., the leading +C (N1+N2)-by-(N1+N2) part of this array must contain the +C orthogonal matrix Z. +C On exit, the leading (N1+N2)-by-(N1+N2) part of this array +C contains the updated matrix Z. Z will be a rotation +C matrix for N1=N2=1. +C This array is not referenced if WANTZ = .FALSE.. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= 1. +C If WANTZ = .TRUE., LDZ >= N1+N2. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: the transformed matrix (A, B) would be +C too far from periodic Schur form; the blocks are +C not swapped and (A,B) and (Q,Z) are unchanged. +C +C METHOD +C +C In the current code both weak and strong stability tests are +C performed. The user can omit the strong stability test by changing +C the internal logical parameter WANDS to .FALSE.. See ref. [2] for +C details. +C +C REFERENCES +C +C [1] Kagstrom, B. +C A direct method for reordering eigenvalues in the generalized +C real Schur form of a regular matrix pair (A,B), in M.S. Moonen +C et al (eds.), Linear Algebra for Large Scale and Real-Time +C Applications, Kluwer Academic Publ., 1993, pp. 195-218. +C +C [2] Kagstrom, B., and Poromaa, P. +C Computing eigenspaces with specified eigenvalues of a regular +C matrix pair (A, B) and condition estimation: Theory, +C algorithms and software, Numer. Algorithms, 1996, vol. 12, +C pp. 369-407. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DTGPX2). +C +C KEYWORDS +C +C Eigenvalue, periodic Schur form, reordering +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION TEN + PARAMETER ( TEN = 1.0D+01 ) + INTEGER LDST + PARAMETER ( LDST = 4 ) + LOGICAL WANDS + PARAMETER ( WANDS = .TRUE. ) +C .. Scalar Arguments .. + LOGICAL WANTQ, WANTZ + INTEGER INFO, LDA, LDB, LDQ, LDZ, N1, N2 +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL DTRONG, WEAK + INTEGER I, LINFO, M + DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS, + $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS +C .. Local Arrays .. + INTEGER IWORK( LDST ) + DOUBLE PRECISION AI(2), AR(2), BE(2), DWORK(32), IR(LDST,LDST), + $ IRCOP(LDST,LDST), LI(LDST,LDST), + $ LICOP(LDST,LDST), S(LDST,LDST), + $ SCPY(LDST,LDST), T(LDST,LDST), TAUL(LDST), + $ TAUR(LDST), TCPY(LDST,LDST) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLARTG, DLASET, + $ DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2, DROT, + $ DSCAL, MB03YT, SB04OW +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C +C .. Executable Statements .. +C + INFO = 0 +C +C Quick return if possible. +C For efficiency, the arguments are not checked. +C + IF ( N1.LE.0 .OR. N2.LE.0 ) + $ RETURN + M = N1 + N2 +C + WEAK = .FALSE. + DTRONG = .FALSE. +C +C Make a local copy of selected block. +C + CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, LI, LDST ) + CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, IR, LDST ) + CALL DLACPY( 'Full', M, M, A, LDA, S, LDST ) + CALL DLACPY( 'Full', M, M, B, LDB, T, LDST ) +C +C Compute threshold for testing acceptance of swapping. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + DSCALE = ZERO + DSUM = ONE + CALL DLACPY( 'Full', M, M, S, LDST, DWORK, M ) + CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) + CALL DLACPY( 'Full', M, M, T, LDST, DWORK, M ) + CALL DLASSQ( M*M, DWORK, 1, DSCALE, DSUM ) + DNORM = DSCALE*SQRT( DSUM ) + THRESH = MAX( TEN*EPS*DNORM, SMLNUM ) +C + IF ( M.EQ.2 ) THEN +C +C CASE 1: Swap 1-by-1 and 1-by-1 blocks. +C +C Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks +C using Givens rotations and perform the swap tentatively. +C + F = S(2,2)*T(2,2) - T(1,1)*S(1,1) + G = -S(2,2)*T(1,2) - T(1,1)*S(1,2) + SB = ABS( T(1,1) ) + SA = ABS( S(2,2) ) + CALL DLARTG( F, G, IR(1,2), IR(1,1), DDUM ) + IR(2,1) = -IR(1,2) + IR(2,2) = IR(1,1) + CALL DROT( 2, S(1,1), 1, S(1,2), 1, IR(1,1), IR(2,1) ) + CALL DROT( 2, T(1,1), LDST, T(2,1), LDST, IR(1,1), IR(2,1) ) + IF( SA.GE.SB ) THEN + CALL DLARTG( S(1,1), S(2,1), LI(1,1), LI(2,1), DDUM ) + ELSE + CALL DLARTG( T(2,2), T(2,1), LI(1,1), LI(2,1), DDUM ) + LI(2,1) = -LI(2,1) + END IF + CALL DROT( 2, S(1,1), LDST, S(2,1), LDST, LI(1,1), LI(2,1) ) + CALL DROT( 2, T(1,1), 1, T(1,2), 1, LI(1,1), LI(2,1) ) + LI(2,2) = LI(1,1) + LI(1,2) = -LI(2,1) +C +C Weak stability test: +C |S21| + |T21| <= O(EPS * F-norm((S, T))). +C + WS = ABS( S(2,1) ) + ABS( T(2,1) ) + WEAK = WS.LE.THRESH + IF ( .NOT.WEAK ) + $ GO TO 50 +C + IF ( WANDS ) THEN +C +C Strong stability test: +C F-norm((A-QL'*S*QR, B-QR'*T*QL)) <= O(EPS*F-norm((A,B))). +C + CALL DLACPY( 'Full', M, M, A, LDA, DWORK(M*M+1), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, + $ LI, LDST, S, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, + $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) + DSCALE = ZERO + DSUM = ONE + CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) +C + CALL DLACPY( 'Full', M, M, B, LDB, DWORK(M*M+1), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, + $ IR, LDST, T, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, + $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) + CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) + SS = DSCALE*SQRT( DSUM ) + DTRONG = SS.LE.THRESH + IF( .NOT.DTRONG ) + $ GO TO 50 + END IF +C +C Update A and B. +C + CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) + CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) +C +C Set N1-by-N2 (2,1) - blocks to ZERO. +C + A(2,1) = ZERO + B(2,1) = ZERO +C +C Accumulate transformations into Q and Z if requested. +C + IF ( WANTQ ) + $ CALL DROT( 2, Q(1,1), 1, Q(1,2), 1, LI(1,1), LI(2,1) ) + IF ( WANTZ ) + $ CALL DROT( 2, Z(1,1), 1, Z(1,2), 1, IR(1,1), IR(2,1) ) +C +C Exit with INFO = 0 if swap was successfully performed. +C + RETURN +C + ELSE +C +C CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 +C and 2-by-2 blocks. +C +C Solve the periodic Sylvester equation +C S11 * R - L * S22 = SCALE * S12 +C T11 * L - R * T22 = SCALE * T12 +C for R and L. Solutions in IR and LI. +C + CALL DLACPY( 'Full', N1, N2, T(1,N1+1), LDST, LI, LDST ) + CALL DLACPY( 'Full', N1, N2, S(1,N1+1), LDST, IR(N2+1,N1+1), + $ LDST ) + CALL SB04OW( N1, N2, S, LDST, S(N1+1,N1+1), LDST, + $ IR(N2+1,N1+1), LDST, T, LDST, T(N1+1,N1+1), LDST, + $ LI, LDST, SCALE, IWORK, LINFO ) + IF ( LINFO.NE.0 ) + $ GO TO 50 +C +C Compute orthogonal matrix QL: +C +C QL' * LI = [ TL ] +C [ 0 ] +C where +C LI = [ -L ]. +C [ SCALE * identity(N2) ] +C + DO 10 I = 1, N2 + CALL DSCAL( N1, -ONE, LI(1,I), 1 ) + LI(N1+I,I) = SCALE + 10 CONTINUE + CALL DGEQR2( M, N2, LI, LDST, TAUL, DWORK, LINFO ) + CALL DORG2R( M, M, N2, LI, LDST, TAUL, DWORK, LINFO ) +C +C Compute orthogonal matrix RQ: +C +C IR * RQ' = [ 0 TR], +C +C where IR = [ SCALE * identity(N1), R ]. +C + DO 20 I = 1, N1 + IR(N2+I,I) = SCALE + 20 CONTINUE + CALL DGERQ2( N1, M, IR(N2+1,1), LDST, TAUR, DWORK, LINFO ) + CALL DORGR2( M, M, N1, IR, LDST, TAUR, DWORK, LINFO ) +C +C Perform the swapping tentatively: +C + CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, LI, + $ LDST, S, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, DWORK, + $ M, IR, LDST, ZERO, S, LDST ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, IR, + $ LDST, T, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, + $ DWORK, M, LI, LDST, ZERO, T, LDST ) + CALL DLACPY( 'All', M, M, S, LDST, SCPY, LDST ) + CALL DLACPY( 'All', M, M, T, LDST, TCPY, LDST ) + CALL DLACPY( 'All', M, M, IR, LDST, IRCOP, LDST ) + CALL DLACPY( 'All', M, M, LI, LDST, LICOP, LDST ) +C +C Triangularize the B-part by a QR factorization. +C Apply transformation (from left) to A-part, giving S. +C + CALL DGEQR2( M, M, T, LDST, TAUR, DWORK, LINFO ) + CALL DORM2R( 'Right', 'No Transpose', M, M, M, T, LDST, TAUR, + $ S, LDST, DWORK, LINFO ) + CALL DORM2R( 'Left', 'Transpose', M, M, M, T, LDST, TAUR, + $ IR, LDST, DWORK, LINFO ) +C +C Compute F-norm(S21) in BRQA21. (T21 is 0.) +C + DSCALE = ZERO + DSUM = ONE + DO 30 I = 1, N2 + CALL DLASSQ( N1, S(N2+1,I), 1, DSCALE, DSUM ) + 30 CONTINUE + BRQA21 = DSCALE*SQRT( DSUM ) +C +C Triangularize the B-part by an RQ factorization. +C Apply transformation (from right) to A-part, giving S. +C + CALL DGERQ2( M, M, TCPY, LDST, TAUL, DWORK, LINFO ) + CALL DORMR2( 'Left', 'No Transpose', M, M, M, TCPY, LDST, + $ TAUL, SCPY, LDST, DWORK, LINFO ) + CALL DORMR2( 'Right', 'Transpose', M, M, M, TCPY, LDST, + $ TAUL, LICOP, LDST, DWORK, LINFO ) +C +C Compute F-norm(S21) in BQRA21. (T21 is 0.) +C + DSCALE = ZERO + DSUM = ONE + DO 40 I = 1, N2 + CALL DLASSQ( N1, SCPY(N2+1,I), 1, DSCALE, DSUM ) + 40 CONTINUE + BQRA21 = DSCALE*SQRT( DSUM ) +C +C Decide which method to use. +C Weak stability test: +C F-norm(S21) <= O(EPS * F-norm((S, T))) +C + IF ( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN + CALL DLACPY( 'All', M, M, SCPY, LDST, S, LDST ) + CALL DLACPY( 'All', M, M, TCPY, LDST, T, LDST ) + CALL DLACPY( 'All', M, M, IRCOP, LDST, IR, LDST ) + CALL DLACPY( 'All', M, M, LICOP, LDST, LI, LDST ) + ELSE IF ( BRQA21.GE.THRESH ) THEN + GO TO 50 + END IF +C +C Set lower triangle of B-part to zero +C + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST ) +C + IF ( WANDS ) THEN +C +C Strong stability test: +C F-norm((A-QL*S*QR', B-QR*T*QL')) <= O(EPS*F-norm((A,B))) +C + CALL DLACPY( 'All', M, M, A, LDA, DWORK(M*M+1), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, + $ LI, LDST, S, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, -ONE, + $ DWORK, M, IR, LDST, ONE, DWORK(M*M+1), M ) + DSCALE = ZERO + DSUM = ONE + CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) +C + CALL DLACPY( 'All', M, M, B, LDB, DWORK(M*M+1), M ) + CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, + $ IR, LDST, T, LDST, ZERO, DWORK, M ) + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, -ONE, + $ DWORK, M, LI, LDST, ONE, DWORK(M*M+1), M ) + CALL DLASSQ( M*M, DWORK(M*M+1), 1, DSCALE, DSUM ) + SS = DSCALE*SQRT( DSUM ) + DTRONG = ( SS.LE.THRESH ) + IF( .NOT.DTRONG ) + $ GO TO 50 +C + END IF +C +C If the swap is accepted ("weakly" and "strongly"), apply the +C transformations and set N1-by-N2 (2,1)-block to zero. +C + CALL DLASET( 'All', N1, N2, ZERO, ZERO, S(N2+1,1), LDST ) +C +C Copy (S,T) to (A,B). +C + CALL DLACPY( 'All', M, M, S, LDST, A, LDA ) + CALL DLACPY( 'All', M, M, T, LDST, B, LDB ) + CALL DLASET( 'All', LDST, LDST, ZERO, ZERO, T, LDST ) +C +C Standardize existing 2-by-2 blocks. +C + CALL DLASET( 'All', M, M, ZERO, ZERO, DWORK, M ) + DWORK(1) = ONE + T(1,1) = ONE + IF ( N2.GT.1 ) THEN + CALL MB03YT( A, LDA, B, LDB, AR, AI, BE, DWORK(1), DWORK(2), + $ T(1,1), T(2,1) ) + DWORK(M+1) = -DWORK(2) + DWORK(M+2) = DWORK(1) + T(N2,N2) = T(1,1) + T(1,2) = -T(2,1) + END IF + DWORK(M*M) = ONE + T(M,M) = ONE +C + IF ( N1.GT.1 ) THEN + CALL MB03YT( A(N2+1,N2+1), LDA, B(N2+1,N2+1), LDB, TAUR, + $ TAUL, DWORK(M*M+1), DWORK(N2*M+N2+1), + $ DWORK(N2*M+N2+2), T(N2+1,N2+1), T(M,M-1) ) + DWORK(M*M) = DWORK(N2*M+N2+1) + DWORK(M*M-1 ) = -DWORK(N2*M+N2+2) + T(M,M) = T(N2+1,N2+1) + T(M-1,M) = -T(M,M-1) + END IF +C + CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, + $ DWORK, M, A(1,N2+1), LDA, ZERO, DWORK(M*M+1), N2 ) + CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, A(1,N2+1), LDA ) + CALL DGEMM( 'Transpose', 'No Transpose', N2, N1, N2, ONE, + $ T(1,1), LDST, B(1,N2+1), LDB, ZERO, + $ DWORK(M*M+1), N2 ) + CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), N2, B(1,N2+1), LDB ) + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, LI, + $ LDST, DWORK, M, ZERO, DWORK(M*M+1), M ) + CALL DLACPY( 'All', M, M, DWORK(M*M+1), M, LI, LDST ) + CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, + $ A(1,N2+1), LDA, T(N2+1,N2+1), LDST, ZERO, + $ DWORK(M*M+1), M ) + CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, A(1,N2+1), LDA ) + CALL DGEMM( 'No Transpose', 'No Transpose', N2, N1, N1, ONE, + $ B(1,N2+1), LDB, DWORK(N2*M+N2+1), M, ZERO, + $ DWORK(M*M+1), M ) + CALL DLACPY( 'All', N2, N1, DWORK(M*M+1), M, B(1,N2+1), LDB ) + CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE, T, + $ LDST, IR, LDST, ZERO, DWORK, M ) + CALL DLACPY( 'All', M, M, DWORK, M, IR, LDST ) +C +C Accumulate transformations into Q and Z if requested. +C + IF( WANTQ ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE, Q, + $ LDQ, LI, LDST, ZERO, DWORK, M ) + CALL DLACPY( 'All', M, M, DWORK, M, Q, LDQ ) + END IF +C + IF( WANTZ ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M, M, M, ONE, Z, + $ LDZ, IR, LDST, ZERO, DWORK, M ) + CALL DLACPY( 'Full', M, M, DWORK, M, Z, LDZ ) +C + END IF +C +C Exit with INFO = 0 if swap was successfully performed. +C + RETURN +C + END IF +C +C Exit with INFO = 1 if swap was rejected. +C + 50 CONTINUE +C + INFO = 1 + RETURN +C *** Last line of MB03WA *** + END diff --git a/mex/sources/libslicot/MB03WD.f b/mex/sources/libslicot/MB03WD.f new file mode 100644 index 000000000..76bd6780d --- /dev/null +++ b/mex/sources/libslicot/MB03WD.f @@ -0,0 +1,966 @@ + SUBROUTINE MB03WD( JOB, COMPZ, N, P, ILO, IHI, ILOZ, IHIZ, H, + $ LDH1, LDH2, Z, LDZ1, LDZ2, WR, WI, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Schur decomposition and the eigenvalues of a +C product of matrices, H = H_1*H_2*...*H_p, with H_1 an upper +C Hessenberg matrix and H_2, ..., H_p upper triangular matrices, +C without evaluating the product. Specifically, the matrices Z_i +C are computed, such that +C +C Z_1' * H_1 * Z_2 = T_1, +C Z_2' * H_2 * Z_3 = T_2, +C ... +C Z_p' * H_p * Z_1 = T_p, +C +C where T_1 is in real Schur form, and T_2, ..., T_p are upper +C triangular. +C +C The routine works primarily with the Hessenberg and triangular +C submatrices in rows and columns ILO to IHI, but optionally applies +C the transformations to all the rows and columns of the matrices +C H_i, i = 1,...,p. The transformations can be optionally +C accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to compute the full +C Schur form or the eigenvalues only, as follows: +C = 'E': Compute the eigenvalues only; +C = 'S': Compute the factors T_1, ..., T_p of the full +C Schur form, T = T_1*T_2*...*T_p. +C +C COMPZ CHARACTER*1 +C Indicates whether or not the user wishes to accumulate +C the matrices Z_1, ..., Z_p, as follows: +C = 'N': The matrices Z_1, ..., Z_p are not required; +C = 'I': Z_i is initialized to the unit matrix and the +C orthogonal transformation matrix Z_i is returned, +C i = 1, ..., p; +C = 'V': Z_i must contain an orthogonal matrix Q_i on +C entry, and the product Q_i*Z_i is returned, +C i = 1, ..., p. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix H. N >= 0. +C +C P (input) INTEGER +C The number of matrices in the product H_1*H_2*...*H_p. +C P >= 1. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that all matrices H_j, j = 2, ..., p, are +C already upper triangular in rows and columns 1:ILO-1 and +C IHI+1:N, and H_1 is upper quasi-triangular in rows and +C columns 1:ILO-1 and IHI+1:N, with H_1(ILO,ILO-1) = 0 +C (unless ILO = 1), and H_1(IHI+1,IHI) = 0 (unless IHI = N). +C The routine works primarily with the Hessenberg submatrix +C in rows and columns ILO to IHI, but applies the +C transformations to all the rows and columns of the +C matrices H_i, i = 1,...,p, if JOB = 'S'. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C ILOZ (input) INTEGER +C IHIZ (input) INTEGER +C Specify the rows of Z to which the transformations must be +C applied if COMPZ = 'I' or COMPZ = 'V'. +C 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. +C +C H (input/output) DOUBLE PRECISION array, dimension +C (LDH1,LDH2,P) +C On entry, the leading N-by-N part of H(*,*,1) must contain +C the upper Hessenberg matrix H_1 and the leading N-by-N +C part of H(*,*,j) for j > 1 must contain the upper +C triangular matrix H_j, j = 2, ..., p. +C On exit, if JOB = 'S', the leading N-by-N part of H(*,*,1) +C is upper quasi-triangular in rows and columns ILO:IHI, +C with any 2-by-2 diagonal blocks corresponding to a pair of +C complex conjugated eigenvalues, and the leading N-by-N +C part of H(*,*,j) for j > 1 contains the resulting upper +C triangular matrix T_j. +C If JOB = 'E', the contents of H are unspecified on exit. +C +C LDH1 INTEGER +C The first leading dimension of the array H. +C LDH1 >= max(1,N). +C +C LDH2 INTEGER +C The second leading dimension of the array H. +C LDH2 >= max(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension +C (LDZ1,LDZ2,P) +C On entry, if COMPZ = 'V', the leading N-by-N-by-P part of +C this array must contain the current matrix Q of +C transformations accumulated by SLICOT Library routine +C MB03VY. +C If COMPZ = 'I', Z need not be set on entry. +C On exit, if COMPZ = 'V', or COMPZ = 'I', the leading +C N-by-N-by-P part of this array contains the transformation +C matrices which produced the Schur form; the +C transformations are applied only to the submatrices +C Z_j(ILOZ:IHIZ,ILO:IHI), j = 1, ..., P. +C If COMPZ = 'N', Z is not referenced. +C +C LDZ1 INTEGER +C The first leading dimension of the array Z. +C LDZ1 >= 1, if COMPZ = 'N'; +C LDZ1 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. +C +C LDZ2 INTEGER +C The second leading dimension of the array Z. +C LDZ2 >= 1, if COMPZ = 'N'; +C LDZ2 >= max(1,N), if COMPZ = 'I' or COMPZ = 'V'. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C The real and imaginary parts, respectively, of the +C computed eigenvalues ILO to IHI are stored in the +C corresponding elements of WR and WI. If two eigenvalues +C are computed as a complex conjugate pair, they are stored +C in consecutive elements of WR and WI, say the i-th and +C (i+1)th, with WI(i) > 0 and WI(i+1) < 0. If JOB = 'S', the +C eigenvalues are stored in the same order as on the +C diagonal of the Schur form returned in H. +C +C Workspace +C +C DWORK DOUBLE PRECISION work array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= IHI-ILO+P-1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, ILO <= i <= IHI, the QR algorithm +C failed to compute all the eigenvalues ILO to IHI +C in a total of 30*(IHI-ILO+1) iterations; +C the elements i+1:IHI of WR and WI contain those +C eigenvalues which have been successfully computed. +C +C METHOD +C +C A refined version of the QR algorithm proposed in [1] and [2] is +C used. The elements of the subdiagonal, diagonal, and the first +C supradiagonal of current principal submatrix of H are computed +C in the process. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G. and Van Dooren, P. +C The periodic Schur decomposition: algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Sreedhar, J. and Van Dooren, P. +C Periodic Schur form and some matrix equations. +C Proc. of the Symposium on the Mathematical Theory of Networks +C and Systems (MTNS'93), Regensburg, Germany (U. Helmke, +C R. Mennicken and J. Saurer, Eds.), Vol. 1, pp. 339-362, 1994. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C FURTHER COMMENTS +C +C Note that for P = 1, the LAPACK Library routine DHSEQR could be +C more efficient on some computer architectures than this routine, +C because DHSEQR uses a block multishift QR algorithm. +C When P is large and JOB = 'S', it could be more efficient to +C compute the product matrix H, and use the LAPACK Library routines. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, and A. Varga, +C German Aerospace Center, DLR Oberpfaffenhofen, February 1999. +C Partly based on the routine PSHQR by A. Varga +C (DLR Oberpfaffenhofen), January 22, 1996. +C +C REVISIONS +C +C Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Eigenvalue, eigenvalue decomposition, Hessenberg form, +C orthogonal transformation, periodic systems, (periodic) Schur +C form, real Schur form, similarity transformation, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) + DOUBLE PRECISION DAT1, DAT2 + PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER COMPZ, JOB + INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH1, LDH2, LDWORK, + $ LDZ1, LDZ2, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION DWORK( * ), H( LDH1, LDH2, * ), WI( * ), + $ WR( * ), Z( LDZ1, LDZ2, * ) +C .. +C .. Local Scalars .. + LOGICAL INITZ, WANTT, WANTZ + INTEGER I, I1, I2, ITN, ITS, J, JMAX, JMIN, K, L, M, + $ NH, NR, NROW, NZ + DOUBLE PRECISION AVE, CS, DISC, H11, H12, H21, H22, H33, H33S, + $ H43H34, H44, H44S, HH10, HH11, HH12, HH21, HH22, + $ HP00, HP01, HP02, HP11, HP12, HP22, OVFL, S, + $ SMLNUM, SN, TAU, TST1, ULP, UNFL, V1, V2, V3 +C .. +C .. Local Arrays .. + DOUBLE PRECISION V( 3 ) +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANHS, DLANTR + EXTERNAL DLAMCH, DLANHS, DLANTR, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DLARFX, DLARTG, + $ DLASET, DROT, MB04PY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + WANTT = LSAME( JOB, 'S' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = LSAME( COMPZ, 'V' ) .OR. INITZ + INFO = 0 + IF( .NOT. ( WANTT .OR. LSAME( JOB, 'E' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( WANTZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.1 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -6 + ELSE IF( ILOZ.LT.1 .OR. ILOZ.GT.ILO ) THEN + INFO = -7 + ELSE IF( IHIZ.LT.IHI .OR. IHIZ.GT.N ) THEN + INFO = -8 + ELSE IF( LDH1.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDH2.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDZ1.LT.1 .OR. ( WANTZ .AND. LDZ1.LT.N ) ) THEN + INFO = -13 + ELSE IF( LDZ2.LT.1 .OR. ( WANTZ .AND. LDZ2.LT.N ) ) THEN + INFO = -14 + ELSE IF( LDWORK.LT.IHI - ILO + P - 1 ) THEN + INFO = -18 + END IF + IF( INFO.EQ.0 ) THEN + IF( ILO.GT.1 ) THEN + IF( H( ILO, ILO-1, 1 ).NE.ZERO ) + $ INFO = -5 + ELSE IF( IHI.LT.N ) THEN + IF( H( IHI+1, IHI, 1 ).NE.ZERO ) + $ INFO = -6 + END IF + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Initialize Z, if necessary. +C + IF( INITZ ) THEN +C + DO 10 J = 1, P + CALL DLASET( 'Full', N, N, ZERO, ONE, Z( 1, 1, J ), LDZ1 ) + 10 CONTINUE +C + END IF +C + NH = IHI - ILO + 1 +C + IF( NH.EQ.1 ) THEN + HP00 = ONE +C + DO 20 J = 1, P + HP00 = HP00 * H( ILO, ILO, J ) + 20 CONTINUE +C + WR( ILO ) = HP00 + WI( ILO ) = ZERO + RETURN + END IF +C +C Set machine-dependent constants for the stopping criterion. +C If norm(H) <= sqrt(OVFL), overflow should not occur. +C + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( DBLE( NH ) / ULP ) +C +C Set the elements in rows and columns ILO to IHI to zero below the +C first subdiagonal in H(*,*,1) and below the first diagonal in +C H(*,*,j), j >= 2. In the same loop, compute and store in +C DWORK(NH:NH+P-2) the 1-norms of the matrices H_2, ..., H_p, to be +C used later. +C + I = NH + S = ULP * DBLE( N ) + IF( NH.GT.2 ) + $ CALL DLASET( 'Lower', NH-2, NH-2, ZERO, ZERO, + $ H( ILO+2, ILO, 1 ), LDH1 ) +C + DO 30 J = 2, P + CALL DLASET( 'Lower', NH-1, NH-1, ZERO, ZERO, + $ H( ILO+1, ILO, J ), LDH1 ) + DWORK( I ) = S * DLANTR( '1-norm', 'Upper', 'NonUnit', NH, NH, + $ H( ILO, ILO, J ), LDH1, DWORK ) + I = I + 1 + 30 CONTINUE +C +C I1 and I2 are the indices of the first row and last column of H +C to which transformations must be applied. If eigenvalues only are +C being computed, I1 and I2 are set inside the main loop. +C + IF( WANTT ) THEN + I1 = 1 + I2 = N + END IF +C + IF( WANTZ ) + $ NZ = IHIZ - ILOZ + 1 +C +C ITN is the total number of QR iterations allowed. +C + ITN = 30*NH +C +C The main loop begins here. I is the loop index and decreases from +C IHI to ILO in steps of 1 or 2. Each iteration of the loop works +C with the active submatrix in rows and columns L to I. +C Eigenvalues I+1 to IHI have already converged. Either L = ILO or +C H(L,L-1) is negligible so that the matrix splits. +C + I = IHI +C + 40 CONTINUE + L = ILO +C +C Perform QR iterations on rows and columns ILO to I until a +C submatrix of order 1 or 2 splits off at the bottom because a +C subdiagonal element has become negligible. +C +C Let T = H_2*...*H_p, and H = H_1*T. Part of the currently +C free locations of WR and WI are temporarily used as workspace. +C +C WR(L:I): the current diagonal elements of h = H(L:I,L:I); +C WI(L+1:I): the current elements of the first subdiagonal of h; +C DWORK(NH-I+L:NH-1): the current elements of the first +C supradiagonal of h. +C + DO 160 ITS = 0, ITN +C +C Initialization: compute H(I,I) (and H(I,I-1) if I > L). +C + HP22 = ONE + IF( I.GT.L ) THEN + HP12 = ZERO + HP11 = ONE +C + DO 50 J = 2, P + HP22 = HP22*H( I, I, J ) + HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) + HP11 = HP11*H( I-1, I-1, J ) + 50 CONTINUE +C + HH21 = H( I, I-1, 1 )*HP11 + HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 +C + WR( I ) = HH22 + WI( I ) = HH21 + ELSE +C + DO 60 J = 1, P + HP22 = HP22*H( I, I, J ) + 60 CONTINUE +C + WR( I ) = HP22 + END IF +C +C Look for a single small subdiagonal element. +C The loop also computes the needed current elements of the +C diagonal and the first two supradiagonals of T, as well as +C the current elements of the central tridiagonal of H. +C + DO 80 K = I, L + 1, -1 +C +C Evaluate H(K-1,K-1), H(K-1,K) (and H(K-1,K-2) if K > L+1). +C + HP00 = ONE + HP01 = ZERO + IF( K.GT.L+1 ) THEN + HP02 = ZERO +C + DO 70 J = 2, P + HP02 = HP00*H( K-2, K, J ) + HP01*H( K-1, K, J ) + $ + HP02*H( K, K, J ) + HP01 = HP00*H( K-2, K-1, J ) + HP01*H( K-1, K-1, J ) + HP00 = HP00*H( K-2, K-2, J ) + 70 CONTINUE +C + HH10 = H( K-1, K-2, 1 )*HP00 + HH11 = H( K-1, K-2, 1 )*HP01 + H( K-1, K-1, 1 )*HP11 + HH12 = H( K-1, K-2, 1 )*HP02 + H( K-1, K-1, 1 )*HP12 + $ + H( K-1, K, 1 )*HP22 + WI( K-1 ) = HH10 + ELSE + HH10 = ZERO + HH11 = H( K-1, K-1, 1 )*HP11 + HH12 = H( K-1, K-1, 1 )*HP12 + H( K-1, K, 1 )*HP22 + END IF + WR( K-1 ) = HH11 + DWORK( NH-I+K-1) = HH12 +C +C Test for a negligible subdiagonal element. +C + TST1 = ABS( HH11 ) + ABS( HH22 ) + IF( TST1.EQ.ZERO ) + $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, + $ DWORK ) + IF( ABS( HH21 ).LE.MAX( ULP*TST1, SMLNUM ) ) + $ GO TO 90 +C +C Update the values for the next cycle. +C + HP22 = HP11 + HP11 = HP00 + HP12 = HP01 + HH22 = HH11 + HH21 = HH10 + 80 CONTINUE +C + 90 CONTINUE + L = K +C + IF( L.GT.ILO ) THEN +C +C H(L,L-1) is negligible. +C + IF( WANTT ) THEN +C +C If H(L,L-1,1) is also negligible, set it to 0; otherwise, +C annihilate the subdiagonal elements bottom-up, and +C restore the triangular form of H(*,*,j). Since H(L,L-1) +C is negligible, the second case can only appear when the +C product of H(L-1,L-1,j), j >= 2, is negligible. +C + TST1 = ABS( H( L-1, L-1, 1 ) ) + ABS( H( L, L, 1 ) ) + IF( TST1.EQ.ZERO ) + $ TST1 = DLANHS( '1-norm', I-L+1, H( L, L, 1 ), LDH1, + $ DWORK ) + IF( ABS( H( L, L-1, 1 ) ).GT.MAX( ULP*TST1, SMLNUM ) ) + $ THEN +C + DO 110 K = I, L, -1 +C + DO 100 J = 1, P - 1 +C +C Compute G to annihilate from the right the +C (K,K-1) element of the matrix H_j. +C + V( 1 ) = H( K, K-1, J ) + CALL DLARFG( 2, H( K, K, J ), V, 1, TAU ) + H( K, K-1, J ) = ZERO + V( 2 ) = ONE +C +C Apply G from the right to transform the columns +C of the matrix H_j in rows I1 to K-1. +C + CALL DLARFX( 'Right', K-I1, 2, V, TAU, + $ H( I1, K-1, J ), LDH1, DWORK ) +C +C Apply G from the left to transform the rows of +C the matrix H_(j+1) in columns K-1 to I2. +C + CALL DLARFX( 'Left', 2, I2-K+2, V, TAU, + $ H( K-1, K-1, J+1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix +C Z_(j+1). +C + CALL DLARFX( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, K-1, J+1 ), LDZ1, + $ DWORK ) + END IF + 100 CONTINUE +C + IF( K.LT.I ) THEN +C +C Compute G to annihilate from the right the +C (K+1,K) element of the matrix H_p. +C + V( 1 ) = H( K+1, K, P ) + CALL DLARFG( 2, H( K+1, K+1, P ), V, 1, TAU ) + H( K+1, K, P ) = ZERO + V( 2 ) = ONE +C +C Apply G from the right to transform the columns +C of the matrix H_p in rows I1 to K. +C + CALL DLARFX( 'Right', K-I1+1, 2, V, TAU, + $ H( I1, K, P ), LDH1, DWORK ) +C +C Apply G from the left to transform the rows of +C the matrix H_1 in columns K to I2. +C + CALL DLARFX( 'Left', 2, I2-K+1, V, TAU, + $ H( K, K, 1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_1. +C + CALL DLARFX( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) + END IF + END IF + 110 CONTINUE +C + H( L, L-1, P ) = ZERO + END IF + H( L, L-1, 1 ) = ZERO + END IF + END IF +C +C Exit from loop if a submatrix of order 1 or 2 has split off. +C + IF( L.GE.I-1 ) + $ GO TO 170 +C +C Now the active submatrix is in rows and columns L to I. If +C eigenvalues only are being computed, only the active submatrix +C need be transformed. +C + IF( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF +C + IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN +C +C Exceptional shift. +C + S = ABS( WI( I ) ) + ABS( WI( I-1 ) ) + H44 = DAT1*S + WR( I ) + H33 = H44 + H43H34 = DAT2*S*S + ELSE +C +C Prepare to use Francis' double shift (i.e., second degree +C generalized Rayleigh quotient). +C + H44 = WR( I ) + H33 = WR( I-1 ) + H43H34 = WI( I )*DWORK( NH-1 ) + DISC = ( H33 - H44 )*HALF + DISC = DISC*DISC + H43H34 + IF( DISC.GT.ZERO ) THEN +C +C Real roots: use Wilkinson's shift twice. +C + DISC = SQRT( DISC ) + AVE = HALF*( H33 + H44 ) + IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN + H33 = H33*H44 - H43H34 + H44 = H33 / ( SIGN( DISC, AVE ) + AVE ) + ELSE + H44 = SIGN( DISC, AVE ) + AVE + END IF + H33 = H44 + H43H34 = ZERO + END IF + END IF +C +C Look for two consecutive small subdiagonal elements. +C + DO 120 M = I - 2, L, -1 +C +C Determine the effect of starting the double-shift QR +C iteration at row M, and see if this would make H(M,M-1) +C negligible. +C + H11 = WR( M ) + H12 = DWORK( NH-I+M ) + H21 = WI( M+1 ) + H22 = WR( M+1 ) + H44S = H44 - H11 + H33S = H33 - H11 + V1 = ( H33S*H44S - H43H34 ) / H21 + H12 + V2 = H22 - H11 - H33S - H44S + V3 = WI( M+2 ) + S = ABS( V1 ) + ABS( V2 ) + ABS( V3 ) + V1 = V1 / S + V2 = V2 / S + V3 = V3 / S + V( 1 ) = V1 + V( 2 ) = V2 + V( 3 ) = V3 + IF( M.EQ.L ) + $ GO TO 130 + TST1 = ABS( V1 )*( ABS( WR( M-1 ) ) + + $ ABS( H11 ) + ABS( H22 ) ) + IF( ABS( WI( M ) )*( ABS( V2 ) + ABS( V3 ) ).LE.ULP*TST1 ) + $ GO TO 130 + 120 CONTINUE +C + 130 CONTINUE +C +C Double-shift QR step. +C + DO 150 K = M, I - 1 +C +C The first iteration of this loop determines a reflection G +C from the vector V and applies it from left and right to H, +C thus creating a nonzero bulge below the subdiagonal. +C +C Each subsequent iteration determines a reflection G to +C restore the Hessenberg form in the (K-1)th column, and thus +C chases the bulge one step toward the bottom of the active +C submatrix. NR is the order of G. +C + NR = MIN( 3, I-K+1 ) + NROW = MIN( K+NR, I ) - I1 + 1 + IF( K.GT.M ) + $ CALL DCOPY( NR, H( K, K-1, 1 ), 1, V, 1 ) + CALL DLARFG( NR, V( 1 ), V( 2 ), 1, TAU ) + IF( K.GT.M ) THEN + H( K, K-1, 1 ) = V( 1 ) + H( K+1, K-1, 1 ) = ZERO + IF( K.LT.I-1 ) + $ H( K+2, K-1, 1 ) = ZERO + ELSE IF( M.GT.L ) THEN + H( K, K-1, 1 ) = -H( K, K-1, 1 ) + END IF +C +C Apply G from the left to transform the rows of the matrix +C H_1 in columns K to I2. +C + CALL MB04PY( 'Left', NR, I2-K+1, V( 2 ), TAU, H( K, K, 1 ), + $ LDH1, DWORK ) +C +C Apply G from the right to transform the columns of the +C matrix H_p in rows I1 to min(K+NR,I). +C + CALL MB04PY( 'Right', NROW, NR, V( 2 ), TAU, H( I1, K, P ), + $ LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_1. +C + CALL MB04PY( 'Right', NZ, NR, V( 2 ), TAU, + $ Z( ILOZ, K, 1 ), LDZ1, DWORK ) + END IF +C + DO 140 J = P, 2, -1 +C +C Apply G1 (and G2, if NR = 3) from the left to transform +C the NR-by-NR submatrix of H_j in position (K,K) to upper +C triangular form. +C +C Compute G1. +C + CALL DCOPY( NR-1, H( K+1, K, J ), 1, V, 1 ) + CALL DLARFG( NR, H( K, K, J ), V, 1, TAU ) + H( K+1, K, J ) = ZERO + IF( NR.EQ.3 ) + $ H( K+2, K, J ) = ZERO +C +C Apply G1 from the left to transform the rows of the +C matrix H_j in columns K+1 to I2. +C + CALL MB04PY( 'Left', NR, I2-K, V, TAU, H( K, K+1, J ), + $ LDH1, DWORK ) +C +C Apply G1 from the right to transform the columns of the +C matrix H_(j-1) in rows I1 to min(K+NR,I). +C + CALL MB04PY( 'Right', NROW, NR, V, TAU, H( I1, K, J-1 ), + $ LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_j. +C + CALL MB04PY( 'Right', NZ, NR, V, TAU, Z( ILOZ, K, J ), + $ LDZ1, DWORK ) + END IF +C + IF( NR.EQ.3 ) THEN +C +C Compute G2. +C + V( 1 ) = H( K+2, K+1, J ) + CALL DLARFG( 2, H( K+1, K+1, J ), V, 1, TAU ) + H( K+2, K+1, J ) = ZERO +C +C Apply G2 from the left to transform the rows of the +C matrix H_j in columns K+2 to I2. +C + CALL MB04PY( 'Left', 2, I2-K-1, V, TAU, + $ H( K+1, K+2, J ), LDH1, DWORK ) +C +C Apply G2 from the right to transform the columns of +C the matrix H_(j-1) in rows I1 to min(K+3,I). +C + CALL MB04PY( 'Right', NROW, 2, V, TAU, + $ H( I1, K+1, J-1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_j. +C + CALL MB04PY( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, K+1, J ), LDZ1, DWORK ) + END IF + END IF + 140 CONTINUE +C + 150 CONTINUE +C + 160 CONTINUE +C +C Failure to converge in remaining number of iterations. +C + INFO = I + RETURN +C + 170 CONTINUE +C + IF( L.EQ.I ) THEN +C +C H(I,I-1,1) is negligible: one eigenvalue has converged. +C Note that WR(I) has already been set. +C + WI( I ) = ZERO + ELSE IF( L.EQ.I-1 ) THEN +C +C H(I-1,I-2,1) is negligible: a pair of eigenvalues have +C converged. +C +C Transform the 2-by-2 submatrix of H_1*H_2*...*H_p in position +C (I-1,I-1) to standard Schur form, and compute and store its +C eigenvalues. If the Schur form is not required, then the +C previously stored values of a similar submatrix are used. +C For real eigenvalues, a Givens transformation is used to +C triangularize the submatrix. +C + IF( WANTT ) THEN + HP22 = ONE + HP12 = ZERO + HP11 = ONE +C + DO 180 J = 2, P + HP22 = HP22*H( I, I, J ) + HP12 = HP11*H( I-1, I, J ) + HP12*H( I, I, J ) + HP11 = HP11*H( I-1, I-1, J ) + 180 CONTINUE +C + HH21 = H( I, I-1, 1 )*HP11 + HH22 = H( I, I-1, 1 )*HP12 + H( I, I, 1 )*HP22 + HH11 = H( I-1, I-1, 1 )*HP11 + HH12 = H( I-1, I-1, 1 )*HP12 + H( I-1, I, 1 )*HP22 + ELSE + HH11 = WR( I-1 ) + HH12 = DWORK( NH-1 ) + HH21 = WI( I ) + HH22 = WR( I ) + END IF +C + CALL DLANV2( HH11, HH12, HH21, HH22, WR( I-1 ), WI( I-1 ), + $ WR( I ), WI( I ), CS, SN ) +C + IF( WANTT ) THEN +C +C Detect negligible diagonal elements in positions (I-1,I-1) +C and (I,I) in H_j, J > 1. +C + JMIN = 0 + JMAX = 0 +C + DO 190 J = 2, P + IF( JMIN.EQ.0 ) THEN + IF( ABS( H( I-1, I-1, J ) ).LE.DWORK( NH+J-2 ) ) + $ JMIN = J + END IF + IF( ABS( H( I, I, J ) ).LE.DWORK( NH+J-2 ) ) JMAX = J + 190 CONTINUE +C + IF( JMIN.NE.0 .AND. JMAX.NE.0 ) THEN +C +C Choose the shorter path if zero elements in both +C (I-1,I-1) and (I,I) positions are present. +C + IF( JMIN-1.LE.P-JMAX+1 ) THEN + JMAX = 0 + ELSE + JMIN = 0 + END IF + END IF +C + IF( JMIN.NE.0 ) THEN +C + DO 200 J = 1, JMIN - 1 +C +C Compute G to annihilate from the right the (I,I-1) +C element of the matrix H_j. +C + V( 1 ) = H( I, I-1, J ) + CALL DLARFG( 2, H( I, I, J ), V, 1, TAU ) + H( I, I-1, J ) = ZERO + V( 2 ) = ONE +C +C Apply G from the right to transform the columns of the +C matrix H_j in rows I1 to I-1. +C + CALL DLARFX( 'Right', I-I1, 2, V, TAU, + $ H( I1, I-1, J ), LDH1, DWORK ) +C +C Apply G from the left to transform the rows of the +C matrix H_(j+1) in columns I-1 to I2. +C + CALL DLARFX( 'Left', 2, I2-I+2, V, TAU, + $ H( I-1, I-1, J+1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Accumulate transformations in the matrix Z_(j+1). +C + CALL DLARFX( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, I-1, J+1 ), LDZ1, DWORK ) + END IF + 200 CONTINUE +C + H( I, I-1, JMIN ) = ZERO +C + ELSE + IF( JMAX.GT.0 .AND. WI( I-1 ).EQ.ZERO ) + $ CALL DLARTG( H( I-1, I-1, 1 ), H( I, I-1, 1 ), CS, SN, + $ TAU ) +C +C Apply the transformation to H. +C + CALL DROT( I2-I+2, H( I-1, I-1, 1 ), LDH1, + $ H( I, I-1, 1 ), LDH1, CS, SN ) + CALL DROT( I-I1+1, H( I1, I-1, P ), 1, H( I1, I, P ), 1, + $ CS, SN ) + IF( WANTZ ) THEN +C +C Apply transformation to Z_1. +C + CALL DROT( NZ, Z( ILOZ, I-1, 1 ), 1, Z( ILOZ, I, 1 ), + $ 1, CS, SN ) + END IF +C + DO 210 J = P, MAX( 2, JMAX+1 ), -1 +C +C Compute G1 to annihilate from the left the (I,I-1) +C element of the matrix H_j. +C + V( 1 ) = H( I, I-1, J ) + CALL DLARFG( 2, H( I-1, I-1, J ), V, 1, TAU ) + H( I, I-1, J ) = ZERO +C +C Apply G1 from the left to transform the rows of the +C matrix H_j in columns I to I2. +C + CALL MB04PY( 'Left', 2, I2-I+1, V, TAU, + $ H( I-1, I, J ), LDH1, DWORK ) +C +C Apply G1 from the right to transform the columns of +C the matrix H_(j-1) in rows I1 to I. +C + CALL MB04PY( 'Right', I-I1+1, 2, V, TAU, + $ H( I1, I-1, J-1 ), LDH1, DWORK ) +C + IF( WANTZ ) THEN +C +C Apply G1 to Z_j. +C + CALL MB04PY( 'Right', NZ, 2, V, TAU, + $ Z( ILOZ, I-1, J ), LDZ1, DWORK ) + END IF + 210 CONTINUE +C + IF( JMAX.GT.0 ) THEN + H( I, I-1, 1 ) = ZERO + H( I, I-1, JMAX ) = ZERO + ELSE + IF( HH21.EQ.ZERO ) + $ H( I, I-1, 1 ) = ZERO + END IF + END IF + END IF + END IF +C +C Decrement number of remaining iterations, and return to start of +C the main loop with new value of I. +C + ITN = ITN - ITS + I = L - 1 + IF( I.GE.ILO ) + $ GO TO 40 +C + RETURN +C +C *** Last line of MB03WD *** + END diff --git a/mex/sources/libslicot/MB03WX.f b/mex/sources/libslicot/MB03WX.f new file mode 100644 index 000000000..b8c3a9e28 --- /dev/null +++ b/mex/sources/libslicot/MB03WX.f @@ -0,0 +1,170 @@ + SUBROUTINE MB03WX( N, P, T, LDT1, LDT2, WR, WI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of a product of matrices, +C T = T_1*T_2*...*T_p, where T_1 is an upper quasi-triangular +C matrix and T_2, ..., T_p are upper triangular matrices. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix T. N >= 0. +C +C P (input) INTEGER +C The number of matrices in the product T_1*T_2*...*T_p. +C P >= 1. +C +C T (input) DOUBLE PRECISION array, dimension (LDT1,LDT2,P) +C The leading N-by-N part of T(*,*,1) must contain the upper +C quasi-triangular matrix T_1 and the leading N-by-N part of +C T(*,*,j) for j > 1 must contain the upper-triangular +C matrix T_j, j = 2, ..., p. +C The elements below the subdiagonal of T(*,*,1) and below +C the diagonal of T(*,*,j), j = 2, ..., p, are not +C referenced. +C +C LDT1 INTEGER +C The first leading dimension of the array T. +C LDT1 >= max(1,N). +C +C LDT2 INTEGER +C The second leading dimension of the array T. +C LDT2 >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C The real and imaginary parts, respectively, of the +C eigenvalues of T. The eigenvalues are stored in the same +C order as on the diagonal of T_1. If T(i:i+1,i:i+1,1) is a +C 2-by-2 diagonal block with complex conjugated eigenvalues +C then WI(i) > 0 and WI(i+1) = -WI(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, eigenvalue decomposition, periodic systems, +C real Schur form, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDT1, LDT2, N, P +C .. Array Arguments .. + DOUBLE PRECISION T( LDT1, LDT2, * ), WI( * ), WR( * ) +C .. Local Scalars .. + INTEGER I, I1, INEXT, J + DOUBLE PRECISION A11, A12, A21, A22, CS, SN, T11, T12, T22 +C .. External Subroutines .. + EXTERNAL DLANV2, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( P.LT.1 ) THEN + INFO = -2 + ELSE IF( LDT1.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDT2.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB03WX', -INFO ) + RETURN + END IF +C + INEXT = 1 + DO 30 I = 1, N + IF( I.LT.INEXT ) + $ GO TO 30 + IF( I.NE.N ) THEN + IF( T( I+1, I, 1 ).NE.ZERO ) THEN +C +C A pair of eigenvalues. First compute the corresponding +C elements of T(I:I+1,I:I+1). +C + INEXT = I + 2 + I1 = I + 1 + T11 = ONE + T12 = ZERO + T22 = ONE +C + DO 10 J = 2, P + T22 = T22*T( I1, I1, J ) + T12 = T11*T( I, I1, J ) + T12*T( I1, I1, J ) + T11 = T11*T( I, I, J ) + 10 CONTINUE +C + A11 = T( I, I, 1 )*T11 + A12 = T( I, I, 1 )*T12 + T( I, I1, 1 )*T22 + A21 = T( I1, I, 1 )*T11 + A22 = T( I1, I, 1 )*T12 + T( I1, I1, 1 )*T22 +C + CALL DLANV2( A11, A12, A21, A22, WR( I ), WI( I ), + $ WR( I1 ), WI( I1 ), CS, SN ) + GO TO 30 + END IF + END IF +C +C Simple eigenvalue. Compute the corresponding element of T(I,I). +C + INEXT = I + 1 + T11 = ONE +C + DO 20 J = 1, P + T11 = T11*T( I, I, J ) + 20 CONTINUE +C + WR( I ) = T11 + WI( I ) = ZERO + 30 CONTINUE +C + RETURN +C *** Last line of MB03WX *** + END diff --git a/mex/sources/libslicot/MB03XD.f b/mex/sources/libslicot/MB03XD.f new file mode 100644 index 000000000..3b68a9726 --- /dev/null +++ b/mex/sources/libslicot/MB03XD.f @@ -0,0 +1,826 @@ + SUBROUTINE MB03XD( BALANC, JOB, JOBU, JOBV, N, A, LDA, QG, LDQG, + $ T, LDT, U1, LDU1, U2, LDU2, V1, LDV1, V2, LDV2, + $ WR, WI, ILO, SCALE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the eigenvalues of a Hamiltonian matrix, +C +C [ A G ] T T +C H = [ T ], G = G, Q = Q, (1) +C [ Q -A ] +C +C where A, G and Q are real n-by-n matrices. +C +C Due to the structure of H all eigenvalues appear in pairs +C (lambda,-lambda). This routine computes the eigenvalues of H +C using an algorithm based on the symplectic URV and the periodic +C Schur decompositions as described in [1], +C +C T [ T G ] +C U H V = [ T ], (2) +C [ 0 -S ] +C +C where U and V are 2n-by-2n orthogonal symplectic matrices, +C S is in real Schur form and T is upper triangular. +C +C The algorithm is backward stable and preserves the eigenvalue +C pairings in finite precision arithmetic. +C +C Optionally, a symplectic balancing transformation to improve the +C conditioning of eigenvalues is computed (see MB04DD). In this +C case, the matrix H in decomposition (2) must be replaced by the +C balanced matrix. +C +C The SLICOT Library routine MB03ZD can be used to compute invariant +C subspaces of H from the output of this routine. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALANC CHARACTER*1 +C Indicates how H should be diagonally scaled and/or +C permuted to reduce its norm. +C = 'N': Do not diagonally scale or permute; +C = 'P': Perform symplectic permutations to make the matrix +C closer to Hamiltonian Schur form. Do not diagonally +C scale; +C = 'S': Diagonally scale the matrix, i.e., replace A, G and +C Q by D*A*D**(-1), D*G*D and D**(-1)*Q*D**(-1) where +C D is a diagonal matrix chosen to make the rows and +C columns of H more equal in norm. Do not permute; +C = 'B': Both diagonally scale and permute A, G and Q. +C Permuting does not change the norm of H, but scaling does. +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to compute the full +C decomposition (2) or the eigenvalues only, as follows: +C = 'E': compute the eigenvalues only; +C = 'S': compute matrices T and S of (2); +C = 'G': compute matrices T, S and G of (2). +C +C JOBU CHARACTER*1 +C Indicates whether or not the user wishes to compute the +C orthogonal symplectic matrix U of (2) as follows: +C = 'N': the matrix U is not computed; +C = 'U': the matrix U is computed. +C +C JOBV CHARACTER*1 +C Indicates whether or not the user wishes to compute the +C orthogonal symplectic matrix V of (2) as follows: +C = 'N': the matrix V is not computed; +C = 'V': the matrix V is computed. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, this array is overwritten. If JOB = 'S' or +C JOB = 'G', the leading N-by-N part of this array contains +C the matrix S in real Schur form of decomposition (2). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain in columns 1:N the lower triangular part of the +C matrix Q and in columns 2:N+1 the upper triangular part +C of the matrix G. +C On exit, this array is overwritten. If JOB = 'G', the +C leading N-by-N+1 part of this array contains in columns +C 2:N+1 the matrix G of decomposition (2). +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= max(1,N). +C +C T (output) DOUBLE PRECISION array, dimension (LDT,N) +C On exit, if JOB = 'S' or JOB = 'G', the leading N-by-N +C part of this array contains the upper triangular matrix T +C of the decomposition (2). Otherwise, this array is used as +C workspace. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U1 (output) DOUBLE PRECISION array, dimension (LDU1,N) +C On exit, if JOBU = 'U', the leading N-by-N part of this +C array contains the (1,1) block of the orthogonal +C symplectic matrix U of decomposition (2). +C +C LDU1 INTEGER +C The leading dimension of the array U1. LDU1 >= 1. +C LDU1 >= N, if JOBU = 'U'. +C +C U2 (output) DOUBLE PRECISION array, dimension (LDU2,N) +C On exit, if JOBU = 'U', the leading N-by-N part of this +C array contains the (2,1) block of the orthogonal +C symplectic matrix U of decomposition (2). +C +C LDU2 INTEGER +C The leading dimension of the array U2. LDU2 >= 1. +C LDU2 >= N, if JOBU = 'U'. +C +C V1 (output) DOUBLE PRECISION array, dimension (LDV1,N) +C On exit, if JOBV = 'V', the leading N-by-N part of this +C array contains the (1,1) block of the orthogonal +C symplectic matrix V of decomposition (2). +C +C LDV1 INTEGER +C The leading dimension of the array V1. LDV1 >= 1. +C LDV1 >= N, if JOBV = 'V'. +C +C V2 (output) DOUBLE PRECISION array, dimension (LDV2,N) +C On exit, if JOBV = 'V', the leading N-by-N part of this +C array contains the (2,1) block of the orthogonal +C symplectic matrix V of decomposition (2). +C +C LDV2 INTEGER +C The leading dimension of the array V2. LDV2 >= 1. +C LDV2 >= N, if JOBV = 'V'. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C On exit, the leading N elements of WR and WI contain the +C real and imaginary parts, respectively, of N eigenvalues +C that have nonpositive real part. Complex conjugate pairs +C of eigenvalues with real part not equal to zero will +C appear consecutively with the eigenvalue having the +C positive imaginary part first. For complex conjugate pairs +C of eigenvalues on the imaginary axis only the eigenvalue +C having nonnegative imaginary part will be returned. +C +C ILO (output) INTEGER +C ILO is an integer value determined when H was balanced. +C The balanced A(i,j) = 0 if I > J and J = 1,...,ILO-1. +C The balanced Q(i,j) = 0 if J = 1,...,ILO-1 or +C I = 1,...,ILO-1. +C +C SCALE (output) DOUBLE PRECISION array, dimension (N) +C On exit, if SCALE = 'S', the leading N elements of this +C array contain details of the permutation and scaling +C factors applied when balancing H, see MB04DD. +C This array is not referenced if BALANC = 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -25, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The dimension of the array DWORK. LDWORK >= max( 1, 8*N ). +C Moreover: +C If JOB = 'E' or 'S' and JOBU = 'N' and JOBV = 'N', +C LDWORK >= 7*N+N*N. +C If JOB = 'G' and JOBU = 'N' and JOBV = 'N', +C LDWORK >= max( 7*N+N*N, 2*N+3*N*N ). +C If JOB = 'G' and JOBU = 'U' and JOBV = 'N', +C LDWORK >= 7*N+2*N*N. +C If JOB = 'G' and JOBU = 'N' and JOBV = 'V', +C LDWORK >= 7*N+2*N*N. +C If JOB = 'G' and JOBU = 'U' and JOBV = 'V', +C LDWORK >= 7*N+N*N. +C For good performance, LDWORK must generally be larger. +C +C Error Indicator +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the periodic QR algorithm failed to +C compute all the eigenvalues, elements i+1:N of WR +C and WI contain eigenvalues which have converged. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. +C Numer. Math., Vol. 78(3), pp. 329-358, 1998. +C +C [2] Benner, P., Mehrmann, V., and Xu, H. +C A new method for computing the stable invariant subspace of a +C real Hamiltonian matrix, J. Comput. Appl. Math., vol. 86, +C pp. 17-43, 1997. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHAESU). +C +C KEYWORDS +C +C Eigenvalues, invariant subspace, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC, JOB, JOBU, JOBV + INTEGER ILO, INFO, LDA, LDQG, LDT, LDU1, LDU2, LDV1, + $ LDV2, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), SCALE(*), + $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), + $ V2(LDV2,*), WI(*), WR(*) +C .. Local Scalars .. + CHARACTER UCHAR, VCHAR + LOGICAL LPERM, LSCAL, SCALEH, WANTG, WANTS, WANTU, + $ WANTV + INTEGER I, IERR, ILO1, J, K, L, PBETA, PCSL, PCSR, PDW, + $ PQ, PTAUL, PTAUR, PZ, WRKMIN, WRKOPT + DOUBLE PRECISION BIGNUM, CSCALE, EPS, HNRM, SMLNUM, TEMP, TEMPI, + $ TEMPR +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, MA02ID + EXTERNAL DLAMCH, LSAME, MA02ID +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASCL, DLASET, + $ DSCAL, MA01AD, MB03XP, MB04DD, MB04QB, MB04TB, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LPERM = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) + LSCAL = LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' ) + WANTS = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'G' ) + WANTG = LSAME( JOB, 'G' ) + WANTU = LSAME( JOBU, 'U' ) + WANTV = LSAME( JOBV, 'V' ) +C + IF ( WANTG ) THEN + IF ( WANTU ) THEN + IF ( WANTV ) THEN + WRKMIN = MAX( 1, 7*N+N*N ) + ELSE + WRKMIN = MAX( 1, 7*N+2*N*N ) + END IF + ELSE + IF ( WANTV ) THEN + WRKMIN = MAX( 1, 7*N+2*N*N ) + ELSE + WRKMIN = MAX( 1, 7*N+N*N, 2*N+3*N*N ) + END IF + END IF + ELSE + IF ( WANTU ) THEN + IF ( WANTV ) THEN + WRKMIN = MAX( 1, 8*N ) + ELSE + WRKMIN = MAX( 1, 8*N ) + END IF + ELSE + IF ( WANTV ) THEN + WRKMIN = MAX( 1, 8*N ) + ELSE + WRKMIN = MAX( 1, 7*N+N*N ) + END IF + END IF + END IF +C + WRKOPT = WRKMIN +C +C Test the scalar input parameters. +C + IF ( .NOT.LPERM .AND. .NOT.LSCAL + $ .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.WANTS .AND. .NOT.LSAME( JOB, 'E' ) ) THEN + INFO = -2 + ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -3 + ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -4 + ELSE IF ( N.LT.0 ) THEN + INFO = -5 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. LDU1.LT.N ) ) THEN + INFO = -13 + ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. LDU2.LT.N ) ) THEN + INFO = -15 + ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. LDV1.LT.N ) ) THEN + INFO = -17 + ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. LDV2.LT.N ) ) THEN + INFO = -19 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + INFO = -25 + DWORK(1) = DBLE( WRKMIN ) + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03XD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + ILO = 0 + IF( N.EQ.0 ) + $ RETURN +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +C +C Scale H if maximal element is outside range [SMLNUM,BIGNUM]. +C + HNRM = MA02ID( 'Hamiltonian', 'MaxElement', N, A, LDA, QG, LDQG, + $ DWORK ) + SCALEH = .FALSE. + IF ( HNRM.GT.ZERO .AND. HNRM.LT.SMLNUM ) THEN + SCALEH = .TRUE. + CSCALE = SMLNUM + ELSE IF( HNRM.GT.BIGNUM ) THEN + SCALEH = .TRUE. + CSCALE = BIGNUM + END IF + IF ( SCALEH ) THEN + CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N, A, LDA, IERR ) + CALL DLASCL( 'General', 0, 0, HNRM, CSCALE, N, N+1, QG, LDQG, + $ IERR ) + END IF +C +C Balance the matrix. +C + CALL MB04DD( BALANC, N, A, LDA, QG, LDQG, ILO, SCALE, IERR ) +C +C Copy A to T and multiply A by -1. +C + CALL DLACPY( 'All', N, N, A, LDA, T, LDT ) + CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, A, LDA, IERR ) +C +C --------------------------------------------- +C Step 1: Compute symplectic URV decomposition. +C --------------------------------------------- +C + PCSL = 1 + PCSR = PCSL + 2*N + PTAUL = PCSR + 2*N + PTAUR = PTAUL + N + PDW = PTAUR + N + + IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN +C +C Copy Q and Q' to workspace. +C + PQ = PDW + PDW = PDW + N*N + DO 20 J = 1, N + K = PQ + (N+1)*(J-1) + L = K + DWORK(K) = QG(J,J) + DO 10 I = J+1, N + K = K + 1 + L = L + N + TEMP = QG(I,J) + DWORK(K) = TEMP + DWORK(L) = TEMP + 10 CONTINUE + 20 CONTINUE + ELSE IF ( WANTU ) THEN +C +C Copy Q and Q' to U2. +C + DO 40 J = 1, N + U2(J,J) = QG(J,J) + DO 30 I = J+1, N + TEMP = QG(I,J) + U2(I,J) = TEMP + U2(J,I) = TEMP + 30 CONTINUE + 40 CONTINUE + ELSE +C +C Copy Q and Q' to V2. +C + DO 60 J = 1, N + V2(J,J) = QG(J,J) + DO 50 I = J+1, N + TEMP = QG(I,J) + V2(I,J) = TEMP + V2(J,I) = TEMP + 50 CONTINUE + 60 CONTINUE + END IF +C +C Transpose G. +C + DO 80 J = 1, N + DO 70 I = J+1, N + QG(I,J+1) = QG(J,I+1) + 70 CONTINUE + 80 CONTINUE +C + IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN + CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, + $ LDA, QG(1,2), LDQG, DWORK(PQ), N, DWORK(PCSL), + $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + ELSE IF ( WANTU ) THEN + CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, + $ LDA, QG(1,2), LDQG, U2, LDU2, DWORK(PCSL), + $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + ELSE + CALL MB04TB( 'Not Transposed', 'Transposed', N, ILO, T, LDT, A, + $ LDA, QG(1,2), LDQG, V2, LDV2, DWORK(PCSL), + $ DWORK(PCSR), DWORK(PTAUL), DWORK(PTAUR), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, QG(2,1), LDQG ) + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN + IF ( N.GT.1 ) THEN + CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) + CALL DLACPY( 'Upper', N-1, N-1, V2(1,2), LDV2, QG(1,2), + $ LDQG ) + END IF + ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN + IF ( N.GT.1 ) THEN + CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, V2(2,1), LDV2 ) + CALL DLACPY( 'Lower', N-1, N-1, A(2,1), LDA, QG(2,1), LDQG ) + END IF + ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, + $ DWORK(PDW+N*N+N), N-1 ) + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, + $ DWORK(PDW+N*N+N), N-2 ) + ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, T(2,1), LDT, + $ DWORK(PDW+N), N-1 ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, V2(3,1), LDV2 ) + END IF +C +C ---------------------------------------------- +C Step 2: Compute periodic Schur decomposition. +C ---------------------------------------------- +C + IF ( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) + IF ( .NOT.WANTU .AND. .NOT.WANTV ) THEN + PBETA = 1 + ELSE + PBETA = PDW + END IF +C + IF ( .NOT.WANTG ) THEN +C +C Workspace requirements: 2*N (8*N with U or V). +C + PDW = PBETA + N + IF ( WANTU ) THEN + UCHAR = 'I' + ELSE + UCHAR = 'N' + END IF + IF ( WANTV ) THEN + VCHAR = 'I' + ELSE + VCHAR = 'N' + END IF + CALL MB03XP( JOB, VCHAR, UCHAR, N, ILO, N, A, LDA, T, LDT, V1, + $ LDV1, U1, LDU1, WR, WI, DWORK(PBETA), DWORK(PDW), + $ LDWORK-PDW+1, INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + ELSE IF ( .NOT.WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 3*N*N + 2*N. +C + PQ = PBETA + N + PZ = PQ + N*N + PDW = PZ + N*N + CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, + $ LDT, DWORK(PQ), N, DWORK(PZ), N, WR, WI, + $ DWORK(PBETA), DWORK(PDW), LDWORK-PDW+1, INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) + ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 2*N*N + 7*N. +C + PQ = PBETA + N + PDW = PQ + N*N + CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, + $ LDT, DWORK(PQ), N, U1, LDU1, WR, WI, DWORK(PBETA), + $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, + $ INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW + $ + (N-1)*(N-1) - 1 ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), + $ LDT ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, + $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PDW), N, DWORK(PQ), N, ZERO, QG(1,2), LDQG ) +C + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 2*N*N + 7*N +C + PZ = PBETA + N + PDW = PZ + N*N + CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, + $ LDT, V1, LDV1, DWORK(PZ), N, WR, WI, DWORK(PBETA), + $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, + $ INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW + $ + (N-1)*(N-1) - 1 ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, DWORK(PDW), N-2, A(3,1), + $ LDA ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PZ), N, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) +C + ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN +C +C Workspace requirements: N*N + 7*N. +C + PDW = PBETA + N + CALL MB03XP( 'Schur', 'Init', 'Init', N, ILO, N, A, LDA, T, + $ LDT, V1, LDV1, U1, LDU1, WR, WI, DWORK(PBETA), + $ DWORK(PDW+(N-1)*(N-1)), LDWORK-PDW-(N-1)*(N-1)+1, + $ INFO ) + IF ( INFO.NE.0 ) + $ GO TO 90 + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(N-1)*(N-1)) ) + PDW + $ + (N-1)*(N-1) - 1 ) + IF ( N.GT.1 ) + $ CALL DLACPY( 'Lower', N-1, N-1, DWORK(PDW), N-1, T(2,1), + $ LDT ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, V2(3,1), LDV2, A(3,1), LDA ) + CALL DGEMM( 'Transpose', 'No Transpose', N, N, N, ONE, + $ U1, LDU1, QG(1,2), LDQG, ZERO, DWORK(PDW), N ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ DWORK(PDW), N, V1, LDV1, ZERO, QG(1,2), LDQG ) + END IF +C + 90 CONTINUE +C +C Compute square roots of eigenvalues and rescale. +C + DO 100 I = INFO + 1, N + TEMPR = WR(I) + TEMPI = WI(I) + TEMP = DWORK(PBETA + I - 1) + IF ( TEMP.GT.ZERO ) + $ TEMPR = -TEMPR + TEMP = ABS( TEMP ) + IF ( TEMPI.EQ.ZERO ) THEN + IF ( TEMPR.LT.ZERO ) THEN + WR(I) = ZERO + WI(I) = SQRT( TEMP ) * SQRT( -TEMPR ) + ELSE + WR(I) = -SQRT( TEMP ) * SQRT( TEMPR ) + WI(I) = ZERO + END IF + ELSE + CALL MA01AD( TEMPR, TEMPI, WR(I), WI(I) ) + WR(I) = -WR(I) * SQRT( TEMP ) + IF ( TEMP.GT.0 ) THEN + WI(I) = WI(I) * SQRT( TEMP ) + ELSE + WI(I) = ZERO + END IF + END IF + 100 CONTINUE +C + IF ( SCALEH ) THEN +C +C Undo scaling. +C + CALL DLASCL( 'Hessenberg', 0, 0, CSCALE, HNRM, N, N, A, LDA, + $ IERR ) + CALL DLASCL( 'Upper', 0, 0, CSCALE, HNRM, N, N, T, LDT, IERR ) + If ( WANTG ) + $ CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, N, QG(1,2), + $ LDQG, IERR ) + CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WR, N, IERR ) + CALL DLASCL( 'General', 0, 0, CSCALE, HNRM, N, 1, WI, N, IERR ) + END IF +C + IF ( INFO.NE.0 ) + $ RETURN +C +C ----------------------------------------------- +C Step 3: Compute orthogonal symplectic factors. +C ----------------------------------------------- +C +C Fix CSL and CSR for MB04QB. +C + IF ( WANTU ) + $ CALL DSCAL( N, -ONE, DWORK(PCSL+1), 2 ) + IF ( WANTV ) + $ CALL DSCAL( N-1, -ONE, DWORK(PCSR+1), 2 ) + ILO1 = MIN( N, ILO + 1 ) +C + IF ( WANTU .AND. .NOT.WANTV .AND. .NOT.WANTG ) THEN +C +C Workspace requirements: 7*N. +C + PDW = PTAUR + CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) + CALL DLACPY( 'Lower', N, N, U2, LDU2, T, LDT ) + CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, + $ QG(ILO,ILO), LDQG, T(ILO,ILO), LDT, U1(ILO,1), + $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), + $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) + CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) +C + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN +C +C Workspace requirements: 7*N. +C + PDW = PTAUR + N + CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, + $ MAX(0,N-ILO), QG(ILO1,ILO), LDQG, QG(ILO,ILO1), + $ LDQG, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, + $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + ELSE IF ( WANTU .AND. WANTV .AND. .NOT.WANTG ) THEN +C +C Workspace requirements: 8*N. +C + PDW = PTAUR + N + CALL DCOPY( N, T(1,1), LDT+1, DWORK(PDW), 1 ) + CALL DLACPY( 'Lower', N, N, V2, LDV2, T, LDT ) + CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, + $ MAX(0,N-ILO), QG(ILO1,ILO), LDQG, U2(ILO,ILO1), + $ LDU2, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, + $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), + $ DWORK(PDW+N), LDWORK-PDW-N+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) +C + CALL DLACPY( 'Lower', N, N, U2, LDU2, QG, LDQG ) + CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, + $ T(ILO,ILO), LDT, QG(ILO,ILO), LDQG, U1(ILO,1), + $ LDU1, U2(ILO,1), LDU2, DWORK(PCSL+2*ILO-2), + $ DWORK(PTAUL+ILO-1), DWORK(PDW+N), LDWORK-PDW-N+1, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) + CALL DCOPY( N, DWORK(PDW), 1, T(1,1), LDT+1 ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) +C + ELSE IF ( WANTU .AND. .NOT.WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 6*N + N*N. +C + PQ = PTAUR + PDW = PQ + N*N + CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) + CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, + $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, + $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, + $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) +C + ELSE IF ( .NOT.WANTU .AND. WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 7*N + N*N. +C + PQ = PTAUR+N + PDW = PQ + N*N + CALL DLACPY( 'Upper', N, N, V2, LDV2, DWORK(PQ), N ) + CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, + $ MAX(0,N-ILO), A(ILO1,ILO), LDA, + $ DWORK(PQ+ILO*N+ILO-1), N, V1(ILO1,1), LDV1, + $ V2(ILO1,1), LDV2, DWORK(PCSR+2*ILO-2), + $ DWORK(PTAUR+ILO-1), DWORK(PDW+N), + $ LDWORK-PDW-N+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+N) ) + PDW + N - 1 ) + IF ( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) +C + ELSE IF ( WANTU .AND. WANTV .AND. WANTG ) THEN +C +C Workspace requirements: 6*N + N*N. +C + PDW = PTAUR + N + CALL DLASET( 'All', N, N, ZERO, ZERO, V2, LDV2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Rowwise', MAX(0,N-ILO), N, + $ MAX(0,N-ILO), A(ILO1,ILO), LDA, U2(ILO,ILO1), + $ LDU2, V1(ILO1,1), LDV1, V2(ILO1,1), LDV2, + $ DWORK(PCSR+2*ILO-2), DWORK(PTAUR+ILO-1), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + PQ = PTAUR + PDW = PQ + N*N + CALL DLACPY( 'Lower', N, N, U2, LDU2, DWORK(PQ), N ) + CALL DLASET( 'All', N, N, ZERO, ZERO, U2, LDU2 ) + CALL MB04QB( 'No Transpose', 'No Transpose', 'No Transpose', + $ 'Columnwise', 'Columnwise', N-ILO+1, N, N-ILO+1, + $ T(ILO,ILO), LDT, DWORK(PQ+(ILO-1)*(N+1)), N, + $ U1(ILO,1), LDU1, U2(ILO,1), LDU2, + $ DWORK(PCSL+2*ILO-2), DWORK(PTAUL+ILO-1), + $ DWORK(PDW), LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) + IF ( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, T(2,1), LDT ) + END IF +C + DWORK(1) = DBLE( WRKOPT ) + RETURN +C *** Last line of MB03XD *** + END diff --git a/mex/sources/libslicot/MB03XP.f b/mex/sources/libslicot/MB03XP.f new file mode 100644 index 000000000..bf374c251 --- /dev/null +++ b/mex/sources/libslicot/MB03XP.f @@ -0,0 +1,659 @@ + SUBROUTINE MB03XP( JOB, COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, + $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the periodic Schur decomposition and the eigenvalues of +C a product of matrices, H = A*B, with A upper Hessenberg and B +C upper triangular without evaluating any part of the product. +C Specifically, the matrices Q and Z are computed, so that +C +C Q' * A * Z = S, Z' * B * Q = T +C +C where S is in real Schur form, and T is upper triangular. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to compute the full +C Schur form or the eigenvalues only, as follows: +C = 'E': Compute the eigenvalues only; +C = 'S': compute the factors S and T of the full +C Schur form. +C +C COMPQ CHARACTER*1 +C Indicates whether or not the user wishes to accumulate +C the matrix Q as follows: +C = 'N': The matrix Q is not required; +C = 'I': Q is initialized to the unit matrix and the +C orthogonal transformation matrix Q is returned; +C = 'V': Q must contain an orthogonal matrix U on entry, +C and the product U*Q is returned. +C +C COMPZ CHARACTER*1 +C Indicates whether or not the user wishes to accumulate +C the matrix Z as follows: +C = 'N': The matrix Z is not required; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned; +C = 'V': Z must contain an orthogonal matrix U on entry, +C and the product U*Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that the matrices A and B are already upper +C triangular in rows and columns 1:ILO-1 and IHI+1:N. +C The routine works primarily with the submatrices in rows +C and columns ILO to IHI, but applies the transformations to +C all the rows and columns of the matrices A and B, if +C JOB = 'S'. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array A must +C contain the upper Hessenberg matrix A. +C On exit, if JOB = 'S', the leading N-by-N part of this +C array is upper quasi-triangular with any 2-by-2 diagonal +C blocks corresponding to a pair of complex conjugated +C eigenvalues. +C If JOB = 'E', the diagonal elements and 2-by-2 diagonal +C blocks of A will be correct, but the remaining parts of A +C are unspecified on exit. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array B must +C contain the upper triangular matrix B. +C On exit, if JOB = 'S', the leading N-by-N part of this +C array contains the transformed upper triangular matrix. +C 2-by-2 blocks in B corresponding to 2-by-2 blocks in A +C will be reduced to positive diagonal form. (I.e., if +C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) +C and B(j+1,j+1) will be positive.) +C If JOB = 'E', the elements corresponding to diagonal +C elements and 2-by-2 diagonal blocks in A will be correct, +C but the remaining parts of B are unspecified on exit. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if COMPQ = 'V', then the leading N-by-N part of +C this array must contain a matrix Q which is assumed to be +C equal to the unit matrix except for the submatrix +C Q(ILO:IHI,ILO:IHI). +C If COMPQ = 'I', Q need not be set on entry. +C On exit, if COMPQ = 'V' or COMPQ = 'I' the leading N-by-N +C part of this array contains the transformation matrix +C which produced the Schur form. +C If COMPQ = 'N', Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= 1. +C If COMPQ <> 'N', LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if COMPZ = 'V', then the leading N-by-N part of +C this array must contain a matrix Z which is assumed to be +C equal to the unit matrix except for the submatrix +C Z(ILO:IHI,ILO:IHI). +C If COMPZ = 'I', Z need not be set on entry. +C On exit, if COMPZ = 'V' or COMPZ = 'I' the leading N-by-N +C part of this array contains the transformation matrix +C which produced the Schur form. +C If COMPZ = 'N', Z is not referenced. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= 1. +C If COMPZ <> 'N', LDZ >= MAX(1,N). +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C The i-th (1 <= i <= N) computed eigenvalue is given by +C BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two +C eigenvalues are computed as a complex conjugate pair, +C they are stored in consecutive elements of ALPHAR, ALPHAI +C and BETA. If JOB = 'S', the eigenvalues are stored in the +C same order as on the diagonales of the Schur forms of A +C and B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then MB03XP failed to compute the Schur +C form in a total of 30*(IHI-ILO+1) iterations; +C elements 1:ilo-1 and i+1:n of ALPHAR, ALPHAI and +C BETA contain successfully computed eigenvalues. +C +C METHOD +C +C The implemented algorithm is a multi-shift version of the periodic +C QR algorithm described in [1,3] with some minor modifications +C proposed in [2]. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. +C The periodic Schur decomposition: Algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Kressner, D. +C An efficient and reliable implementation of the periodic QZ +C algorithm. Proc. of the IFAC Workshop on Periodic Control +C Systems, pp. 187-192, 2001. +C +C [3] Van Loan, C. +C Generalized Singular Values with Algorithms and Applications. +C Ph. D. Thesis, University of Michigan, 1973. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**3) floating point operations and is +C backward stable. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, May 2008 (SLICOT version of the HAPACK routine DHGPQR). +C +C KEYWORDS +C +C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal +C transformation, (periodic) Schur form +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER NSMAX, LDAS, LDBS + PARAMETER ( NSMAX = 15, LDAS = NSMAX, LDBS = NSMAX ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOB + INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDWORK, LDZ, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), + $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL INITQ, INITZ, WANTQ, WANTT, WANTZ + INTEGER DUM, I, I1, I2, IERR, ITEMP, ITN, ITS, J, K, + $ KK, L, MAXB, NH, NR, NS, NV, PV2, PV3 + DOUBLE PRECISION OVFL, SMLNUM, TAUV, TAUW, TEMP, TST, ULP, UNFL +C .. Local Arrays .. + INTEGER ISEED(4) + DOUBLE PRECISION AS(LDAS,LDAS), BS(LDBS,LDBS), V(3*NSMAX+6) +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX, UE01MD + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, IDAMAX, LSAME, UE01MD +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLABAD, DLACPY, DLARFG, + $ DLARFX, DLARNV, DLASET, DSCAL, DTRMV, MB03YA, + $ MB03YD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + WANTT = LSAME( JOB, 'S' ) + INITQ = LSAME( COMPQ, 'I' ) + WANTQ = INITQ.OR.LSAME( COMPQ, 'V' ) + INITZ = LSAME( COMPZ, 'I' ) + WANTZ = INITZ.OR.LSAME( COMPZ, 'V' ) +C +C Check the scalar input parameters. +C + INFO = 0 + IF ( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN + INFO = -1 + ELSE IF ( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN + INFO = -2 + ELSE IF ( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN + INFO = -3 + ELSE IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF ( IHI.LT.MIN( ILO,N ).OR.IHI.GT.N ) THEN + INFO = -6 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN + INFO = -12 + ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN + INFO = -14 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -19 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03XP', -INFO ) + RETURN + END IF +C +C Initialize Q and Z, if necessary. +C + IF ( INITQ ) + $ CALL DLASET( 'All', N, N, ZERO, ONE, Q, LDQ ) + IF ( INITZ ) + $ CALL DLASET( 'All', N, N, ZERO, ONE, Z, LDZ ) +C +C Store isolated eigenvalues and standardize B. +C +C FOR I = [1:ILO-1, IHI+1:N] + I = 1 + 10 CONTINUE + IF ( I.EQ.ILO ) THEN + I = IHI+1 + END IF + IF ( I.LE.N ) THEN + IF ( B(I,I).LT.ZERO ) THEN + IF ( WANTT ) THEN + DO 20 K = ILO, I + B(K,I) = -B(K,I) + 20 CONTINUE + DO 30 K = I, IHI + A(I,K) = -A(I,K) + 30 CONTINUE + ELSE + B(I,I) = -B(I,I) + A(I,I) = -A(I,I) + END IF + IF ( WANTQ ) THEN + DO 40 K = ILO, IHI + Q(K,I) = -Q(K,I) + 40 CONTINUE + END IF + END IF + ALPHAR(I) = A(I,I) + ALPHAI(I) = ZERO + BETA(I) = B(I,I) + I = I + 1 +C END FOR + GO TO 10 + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. ILO.EQ.IHI+1 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Set rows and coloms ILO to IHI of B (A) to zero below the first +C (sub)diagonal. +C + DO 60 J = ILO, IHI - 2 + DO 50 I = J + 2, N + A(I,J) = ZERO + 50 CONTINUE + 60 CONTINUE + DO 80 J = ILO, IHI - 1 + DO 70 I = J + 1, N + B(I,J) = ZERO + 70 CONTINUE + 80 CONTINUE + NH = IHI - ILO + 1 +C +C Suboptimal choice of the number of shifts. +C + IF ( WANTQ ) THEN + NS = UE01MD( 4, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) + MAXB = UE01MD( 8, 'MB03XP', JOB // COMPQ, N, ILO, IHI ) + ELSE + NS = UE01MD( 4, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) + MAXB = UE01MD( 8, 'MB03XP', JOB // COMPZ, N, ILO, IHI ) + END IF +C + IF ( NS.LE.2 .OR. NS.GT.NH .OR. MAXB.GE.NH ) THEN +C +C Standard double-shift product QR. +C + CALL MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILO, IHI, A, + $ LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, + $ DWORK, LDWORK, INFO ) + RETURN + END IF + MAXB = MAX( 3, MAXB ) + NS = MIN( NS, MAXB, NSMAX ) +C +C Set machine-dependent constants for the stopping criterion. +C If max(norm(A),norm(B)) <= sqrt(OVFL), then overflow should not +C occur. +C + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( DBLE( NH ) / ULP ) +C +C I1 and I2 are the indices of the first rows and last columns of +C A and B to which transformations must be applied. +C + IF ( WANTT ) THEN + I1 = 1 + I2 = N + END IF + ISEED(1) = 1 + ISEED(2) = 0 + ISEED(3) = 0 + ISEED(4) = 1 +C +C ITN is the maximal number of QR iterations. +C + ITN = 30*NH + DUM = 0 +C +C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO +C or A(L,L-1) is negligible. +C + I = IHI + 90 CONTINUE + L = ILO + IF ( I.LT.ILO ) + $ GO TO 210 +C + DO 190 ITS = 0, ITN + DUM = DUM + (IHI-ILO)*(IHI-ILO) +C +C Look for deflations in A. +C + DO 100 K = I, L + 1, -1 + TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) + IF ( TST.EQ.ZERO ) + $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) + IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) + $ GO TO 110 + 100 CONTINUE + 110 CONTINUE +C +C Look for deflation in B if problem size is greater than 1. +C + IF ( I-K.GE.1 ) THEN + DO 120 KK = I, K, -1 + IF ( KK.EQ.I ) THEN + TST = ABS( B(KK-1,KK) ) + ELSE IF ( KK.EQ.K ) THEN + TST = ABS( B(KK,KK+1) ) + ELSE + TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) + END IF + IF ( TST.EQ.ZERO ) + $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) + IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) + $ GO TO 130 + 120 CONTINUE + ELSE + KK = K-1 + END IF + 130 CONTINUE + IF ( KK.GE.K ) THEN +C +C B has an element close to zero at position (KK,KK). +C + B(KK,KK) = ZERO + CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILO, IHI, KK, + $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) + K = KK+1 + END IF + L = K + IF( L.GT.ILO ) THEN +C +C A(L,L-1) is negligible. +C + A(L,L-1) = ZERO + END IF +C +C Exit from loop if a submatrix of order <= MAXB has split off. +C + IF ( L.GE.I-MAXB+1 ) + $ GO TO 200 +C +C The active submatrices are now in rows and columns L:I. +C + IF ( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF + IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN +C +C Exceptional shift. The first column of the shift polynomial +C is a pseudo-random vector. +C + CALL DLARNV( 3, ISEED, NS+1, V ) + ELSE +C +C Use eigenvalues of trailing submatrix as shifts. +C + CALL DLACPY( 'Full', NS, NS, A(I-NS+1,I-NS+1), LDA, AS, + $ LDAS ) + CALL DLACPY( 'Full', NS, NS, B(I-NS+1,I-NS+1), LDB, BS, + $ LDBS ) + CALL MB03YD( .FALSE., .FALSE., .FALSE., NS, 1, NS, 1, NS, + $ AS, LDAS, BS, LDBS, Q, LDQ, Z, LDZ, + $ ALPHAR(I-NS+1), ALPHAI(I-NS+1), BETA(I-NS+1), + $ DWORK, LDWORK, IERR ) + END IF +C +C Compute the nonzero elements of the first column of +C (A*B-w(1)) (A*B-w(2)) .. (A*B-w(ns)). +C + V(1) = ONE + NV = 1 +C WHILE NV <= NS + 140 CONTINUE + IF ( NV.LE.NS ) THEN + IF ( NV.EQ.NS .OR. AS(NV+1,NV).EQ.ZERO ) THEN +C +C Real shift. +C + V(NV+1) = ZERO + PV2 = NV+2 + CALL DCOPY( NV, V, 1, V(PV2), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', + $ NV, B(L,L), LDB, V(PV2), 1 ) + CALL DSCAL( NV, BS(NV,NV), V, 1 ) + ITEMP = IDAMAX( 2*NV+1, V, 1 ) + TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) + CALL DSCAL( 2*NV+1, TEMP, V, 1 ) + CALL DGEMV( 'No transpose', NV+1, NV, ONE, A(L,L), LDA, + $ V(PV2), 1, -AS(NV,NV), V, 1 ) + NV = NV + 1 + ELSE +C +C Double shift using a product formulation of the shift +C polynomial [2]. +C + V(NV+1) = ZERO + V(NV+2) = ZERO + PV2 = NV+3 + PV3 = 2*NV+5 + CALL DCOPY( NV+2, V, 1, V(PV2), 1 ) + CALL DCOPY( NV+1, V, 1, V(PV3), 1 ) + CALL DSCAL( NV, BS(NV+1,NV+1), V(PV2), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', + $ NV, B(L,L), LDB, V(PV3), 1 ) + ITEMP = IDAMAX( 2*NV+3, V(PV2), 1 ) + TEMP = ONE / MAX( ABS( V(PV2+ITEMP-1) ), SMLNUM ) + CALL DSCAL( 2*NV+3, TEMP, V(PV2), 1 ) +C + CALL DCOPY( NV, V(PV2), 1, V, 1 ) + CALL DGEMV( 'No transpose', NV+1, NV, -ONE, A(L,L), LDA, + $ V(PV3), 1, AS(NV+1,NV+1), V(PV2), 1 ) + CALL DSCAL( NV, AS(NV,NV+1), V, 1 ) + ITEMP = IDAMAX( 2*NV+3, V, 1 ) + TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) + CALL DSCAL( 2*NV+3, TEMP, V, 1 ) +C + CALL DSCAL( NV, -AS(NV+1,NV), V, 1 ) + CALL DAXPY( NV+1, AS(NV,NV), V(PV2), 1, V, 1) + ITEMP = IDAMAX( 2*NV+3, V, 1 ) + TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) + CALL DSCAL( 2*NV+3, TEMP, V, 1 ) +C + CALL DSCAL( NV+1, BS(NV,NV), V, 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'No unit diagonal', + $ NV+1, B(L,L), LDB, V(PV2), 1 ) + ITEMP = IDAMAX( 2*NV+3, V, 1 ) + TEMP = ONE / MAX( ABS( V(ITEMP) ), SMLNUM ) + CALL DSCAL( 2*NV+3, TEMP, V, 1 ) +C + CALL DGEMV( 'No transpose', NV+2, NV+1, -ONE, A(L,L), + $ LDA, V(PV2), 1, ONE, V, 1 ) + NV = NV + 2 + END IF + ITEMP = IDAMAX( NV, V, 1 ) + TEMP = ABS( V(ITEMP) ) + IF ( TEMP.EQ.ZERO ) THEN + V(1) = ONE + DO 150 K = 2, NV + V(K) = ZERO + 150 CONTINUE + ELSE + TEMP = MAX( TEMP, SMLNUM ) + CALL DSCAL( NV, ONE/TEMP, V, 1 ) + END IF + GO TO 140 +C END WHILE + END IF +C +C Multi-shift product QR step. +C + PV2 = NS+2 + DO 180 K = L,I-1 + NR = MIN( NS+1,I-K+1 ) + IF ( K.GT.L ) + $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) + CALL DLARFG( NR, V(1), V(2), 1, TAUV ) + IF ( K.GT.L ) THEN + A(K,K-1) = V(1) + DO 160 KK = K+1,I + A(KK,K-1) = ZERO + 160 CONTINUE + END IF +C +C Apply reflector V from the right to B in rows +C I1:min(K+NS,I). +C + V(1) = ONE + CALL DLARFX( 'Right', MIN(K+NS,I)-I1+1, NR, V, TAUV, + $ B(I1,K), LDB, DWORK ) +C +C Annihilate the introduced nonzeros in the K-th column. +C + CALL DCOPY( NR, B(K,K), 1, V(PV2), 1 ) + CALL DLARFG( NR, V(PV2), V(PV2+1), 1, TAUW ) + B(K,K) = V(PV2) + DO 170 KK = K+1,I + B(KK,K) = ZERO + 170 CONTINUE + V(PV2) = ONE +C +C Apply reflector W from the left to transform the rows of the +C matrix B in columns K+1:I2. +C + CALL DLARFX( 'Left', NR, I2-K, V(PV2), TAUW, B(K,K+1), LDB, + $ DWORK ) +C +C Apply reflector V from the left to transform the rows of the +C matrix A in columns K:I2. +C + CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, + $ DWORK ) +C +C Apply reflector W from the right to transform the columns of +C the matrix A in rows I1:min(K+NS,I). +C + CALL DLARFX( 'Right', MIN(K+NS+1,I)-I1+1, NR, V(PV2), TAUW, + $ A(I1,K), LDA, DWORK ) +C +C Accumulate transformations in the matrices Q and Z. +C + IF ( WANTQ ) + $ CALL DLARFX( 'Right', NH, NR, V, TAUV, Q(ILO,K), LDQ, + $ DWORK ) + IF ( WANTZ ) + $ CALL DLARFX( 'Right', NH, NR, V(PV2), TAUW, Z(ILO,K), + $ LDZ, DWORK ) + 180 CONTINUE + 190 CONTINUE +C +C Failure to converge. +C + INFO = I + RETURN + 200 CONTINUE +C +C Submatrix of order <= MAXB has split off. Use double-shift +C periodic QR algorithm. +C + CALL MB03YD( WANTT, WANTQ, WANTZ, N, L, I, ILO, IHI, A, LDA, B, + $ LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, + $ LDWORK, INFO ) + IF ( INFO.GT.0 ) + $ RETURN + ITN = ITN - ITS + I = L - 1 + GO TO 90 +C + 210 CONTINUE + DWORK(1) = DBLE( MAX( 1,N ) ) + RETURN +C *** Last line of MB03XP *** + END diff --git a/mex/sources/libslicot/MB03XU.f b/mex/sources/libslicot/MB03XU.f new file mode 100644 index 000000000..b25d49da3 --- /dev/null +++ b/mex/sources/libslicot/MB03XU.f @@ -0,0 +1,2338 @@ + SUBROUTINE MB03XU( LTRA, LTRB, N, K, NB, A, LDA, B, LDB, G, LDG, + $ Q, LDQ, XA, LDXA, XB, LDXB, XG, LDXG, XQ, LDXQ, + $ YA, LDYA, YB, LDYB, YG, LDYG, YQ, LDYQ, CSL, + $ CSR, TAUL, TAUR, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce 2*nb columns and rows of a real (k+2n)-by-(k+2n) +C matrix H: +C +C [ op(A) G ] +C H = [ ], +C [ Q op(B) ] +C +C so that elements in the first nb columns below the k-th +C subdiagonal of the (k+n)-by-n matrix op(A), in the first nb +C columns and rows of the n-by-n matrix Q and in the first nb rows +C above the diagonal of the n-by-(k+n) matrix op(B) are zero. +C The reduction is performed by orthogonal symplectic +C transformations UU'*H*VV and matrices U, V, YA, YB, YG, YQ, XA, +C XB, XG, and XQ are returned so that +C +C [ op(Aout)+U*YA'+XA*V' G+U*YG'+XG*V' ] +C UU' H VV = [ ]. +C [ Qout+U*YQ'+XQ*V' op(Bout)+U*YB'+XB*V' ] +C +C This is an auxiliary routine called by MB04TB. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRA LOGICAL +C Specifies the form of op( A ) as follows: +C = .FALSE.: op( A ) = A; +C = .TRUE.: op( A ) = A'. +C +C LTRB LOGICAL +C Specifies the form of op( B ) as follows: +C = .FALSE.: op( B ) = B; +C = .TRUE.: op( B ) = B'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix Q. N >= 0. +C +C K (input) INTEGER +C The offset of the reduction. Elements below the K-th +C subdiagonal in the first NB columns of op(A) are +C reduced to zero. K >= 0. +C +C NB (input) INTEGER +C The number of columns/rows to be reduced. N > NB >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,N) if LTRA = .FALSE. +C (LDA,K+N) if LTRA = .TRUE. +C On entry with LTRA = .FALSE., the leading (K+N)-by-N part +C of this array must contain the matrix A. +C On entry with LTRA = .TRUE., the leading N-by-(K+N) part +C of this array must contain the matrix A. +C On exit with LTRA = .FALSE., the leading (K+N)-by-N part +C of this array contains the matrix Aout and, in the zero +C parts, information about the elementary reflectors used to +C compute the reduction. +C On exit with LTRA = .TRUE., the leading N-by-(K+N) part of +C this array contains the matrix Aout and in the zero parts +C information about the elementary reflectors. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,K+N), if LTRA = .FALSE.; +C LDA >= MAX(1,N), if LTRA = .TRUE.. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,K+N) if LTRB = .FALSE. +C (LDB,N) if LTRB = .TRUE. +C On entry with LTRB = .FALSE., the leading N-by-(K+N) part +C of this array must contain the matrix B. +C On entry with LTRB = .TRUE., the leading (K+N)-by-N part +C of this array must contain the matrix B. +C On exit with LTRB = .FALSE., the leading N-by-(K+N) part +C of this array contains the matrix Bout and, in the zero +C parts, information about the elementary reflectors used to +C compute the reduction. +C On exit with LTRB = .TRUE., the leading (K+N)-by-N part of +C this array contains the matrix Bout and in the zero parts +C information about the elementary reflectors. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N), if LTRB = .FALSE.; +C LDB >= MAX(1,K+N), if LTRB = .TRUE.. +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix G. +C On exit, the leading N-by-N part of this array contains +C the matrix Gout. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix Q. +C On exit, the leading N-by-N part of this array contains +C the matrix Qout and in the zero parts information about +C the elementary reflectors used to compute the reduction. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix XA. +C +C LDXA INTEGER +C The leading dimension of the array XA. LDXA >= MAX(1,N). +C +C XB (output) DOUBLE PRECISION array, dimension (LDXB,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix XB. +C +C LDXB INTEGER +C The leading dimension of the array XB. LDXB >= MAX(1,K+N). +C +C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix XG. +C +C LDXG INTEGER +C The leading dimension of the array XG. LDXG >= MAX(1,K+N). +C +C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix XQ. +C +C LDXQ INTEGER +C The leading dimension of the array XQ. LDXQ >= MAX(1,N). +C +C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix YA. +C +C LDYA INTEGER +C The leading dimension of the array YA. LDYA >= MAX(1,K+N). +C +C YB (output) DOUBLE PRECISION array, dimension (LDYB,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix YB. +C +C LDYB INTEGER +C The leading dimension of the array YB. LDYB >= MAX(1,N). +C +C YG (output) DOUBLE PRECISION array, dimension (LDYG,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix YG. +C +C LDYG INTEGER +C The leading dimension of the array YG. LDYG >= MAX(1,K+N). +C +C YQ (output) DOUBLE PRECISION array, dimension (LDYQ,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix YQ. +C +C LDYQ INTEGER +C The leading dimension of the array YQ. LDYQ >= MAX(1,N). +C +C CSL (output) DOUBLE PRECISION array, dimension (2*NB) +C On exit, the first 2NB elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the left-hand side used to compute the +C reduction. +C +C CSR (output) DOUBLE PRECISION array, dimension (2*NB) +C On exit, the first 2NB-2 elements of this array contain +C the cosines and sines of the symplectic Givens rotations +C applied from the right-hand side used to compute the +C reduction. +C +C TAUL (output) DOUBLE PRECISION array, dimension (NB) +C On exit, the first NB elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied form the left-hand side. +C +C TAUR (output) DOUBLE PRECISION array, dimension (NB) +C On exit, the first NB-1 elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied form the right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (5*NB) +C +C METHOD +C +C For details regarding the representation of the orthogonal +C symplectic matrices UU and VV within the arrays A, B, CSL, CSR, Q, +C TAUL and TAUR see the description of MB04TB. +C +C The contents of A, B, G and Q on exit are illustrated by the +C following example with op(A) = A, op(B) = B, n = 5, k = 2 and +C nb = 2: +C +C ( a r r a a ) ( g g g r r g g ) +C ( a r r a a ) ( g g g r r g g ) +C ( r r r r r ) ( r r r r r r r ) +C A = ( u2 r r r r ), G = ( r r r r r r r ), +C ( u2 u2 r a a ) ( g g g r r g g ) +C ( u2 u2 r a a ) ( g g g r r g g ) +C ( u2 u2 r a a ) ( g g g r r g g ) +C +C ( t t v1 v1 v1 ) ( r r r r r v2 v2 ) +C ( u1 t t v1 v1 ) ( r r r r r r v2 ) +C Q = ( u1 u1 r q q ), B = ( b b b r r b b ). +C ( u1 u1 r q q ) ( b b b r r b b ) +C ( u1 u1 r q q ) ( b b b r r b b ) +C +C where a, b, g and q denote elements of the original matrices, r +C denotes a modified element, t denotes a scalar factor of an +C applied elementary reflector, ui and vi denote elements of the +C matrices U and V, respectively. +C +C NUMERICAL ASPECTS +C +C The algorithm requires ( 16*K + 32*N + 42 )*N*NB + +C ( 16*K + 112*N - 208/3*NB - 69 )*NB*NB - 29/3*NB floating point +C operations and is numerically backward stable. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. +C Numer. Math., Vol. 78 (3), pp. 329-358, 1998. +C +C [2] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT Numerical Mathematics, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLASUB). +C +C KEYWORDS +C +C Elementary matrix operations, Matrix decompositions, Hamiltonian +C matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL LTRA, LTRB + INTEGER K, LDA, LDB, LDG, LDQ, LDXA, LDXB, LDXG, LDXQ, + $ LDYA, LDYB, LDYG, LDYQ, N, NB +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), + $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*), + $ XA(LDXA,*), XB(LDXB,*), XG(LDXG,*), XQ(LDXQ,*), + $ YA(LDYA,*), YB(LDYB,*), YG(LDYG,*), YQ(LDYQ,*) +C .. Local Scalars .. + INTEGER I, J, NB1, NB2, NB3, PDW + DOUBLE PRECISION ALPHA, C, S, TAUQ, TEMP +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL +C +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( N+K.LE.0 ) THEN + RETURN + END IF +C + NB1 = NB + 1 + NB2 = NB + NB + NB3 = NB2 + NB + PDW = NB3 + NB + 1 +C + IF ( LTRA.AND.LTRB ) THEN + DO 90 I = 1, NB +C +C Transform first row/column of A and Q. See routine MB04TS. +C + ALPHA = Q(I,I) + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) + Q(I,I) = ONE + TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) + CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) + TEMP = A(I,K+I) + CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) + CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) + TEMP = A(I,K+I) + A(I,K+I) = ONE +C +C Update XQ with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, + $ Q(I,I), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, + $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) +C +C Update XA with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), + $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update A(i+1:n,k+i). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) +C +C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. +C + CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) +C +C Update XQ with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, + $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, + $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) +C +C Update XA with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), + $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) +C +C Update A(i+1:n,k+i). +C + CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) +C +C Update XG with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ Q(I,I), 1, ZERO, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) +C +C Update G(k+i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) +C +C Update XB with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, + $ Q(I,I), 1, ZERO, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, + $ DWORK, 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) +C +C Update B(:,i). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ Q(I,1), LDQ, ONE, B(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, A(1,K+I), 1, ONE, B(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) +C +C Apply rotation to [ G(k+i,:); B(:,i)' ]. +C + CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) +C + DO 10 J = 1, I-1 + YG(K+I,J) = ZERO + 10 CONTINUE + DO 20 J = 1, I-1 + YG(K+I,NB+J) = ZERO + 20 CONTINUE + DO 30 J = 1, I-1 + YA(K+I,J) = ZERO + 30 CONTINUE + DO 40 J = 1, I-1 + YA(K+I,NB+J) = ZERO + 40 CONTINUE +C +C Update XG with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) +C +C Update G(k+i,:). +C + CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) +C +C Update XB with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I+1, ONE, B(1,I), LDB, + $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) +C +C Update B(:,i). +C + CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) +C + A(I,K+I) = TEMP + Q(I,I) = TAUQ + CSL(2*I-1) = C + CSL(2*I) = S +C +C Transform first row/column of Q and B. +C + ALPHA = Q(I,I+1) + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) + Q(I,I+1) = ONE + TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) + CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) + TEMP = B(K+I+1,I) + CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) + S = -S + CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) + TEMP = B(K+I+1,I) + B(K+I+1,I) = ONE +C +C Update YB with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), + $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ DWORK, 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) +C +C Update B(k+i+1,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) +C +C Update YQ with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ DWORK, 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) +C +C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. +C + CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) + DO 50 J = 1, I + XB(K+I+1,J) = ZERO + 50 CONTINUE + DO 60 J = 1, I + XB(K+I+1,NB+J) = ZERO + 60 CONTINUE +C +C Update YB with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), + $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, + $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, + $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, + $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), + $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) +C +C Update B(k+i+1,i+1:n). +C + CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) +C +C Update YQ with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, + $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) +C +C Update YA with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, + $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C +C Update A(i+1,1:k+n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ B(K+I+1,1), LDB, ONE, A(I+1,1), LDA ) +C +C Update YG with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, + $ DWORK, 1, ONE, YG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) + DO 70 J = 1, I + XG(K+I+1,J) = ZERO + 70 CONTINUE + DO 80 J = 1, I + XG(K+I+1,NB+J) = ZERO + 80 CONTINUE +C +C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. +C + CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) +C +C Update YA with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, + $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) +C +C Update A(i+1,1:k+n). +C + CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) +C +C Update YG with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) +C + B(K+I+1,I) = TEMP + Q(I,I+1) = TAUQ + CSR(2*I-1) = C + CSR(2*I) = S + 90 CONTINUE + ELSE IF ( LTRA ) THEN + DO 180 I = 1, NB +C +C Transform first row/column of A and Q. See routine MB04TS. +C + ALPHA = Q(I,I) + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) + Q(I,I) = ONE + TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(I,K+I), LDA ) + CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(I,K+I), LDA ) + TEMP = A(I,K+I) + CALL DLARTG( TEMP, ALPHA, C, S, A(I,K+I) ) + CALL DLARFG( N-I+1, A(I,K+I), A(I,K+I+1), LDA, TAUL(I) ) + TEMP = A(I,K+I) + A(I,K+I) = ONE +C +C Update XQ with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, + $ Q(I,I), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A(1,K+I), LDA, + $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(1,K+I), 1, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) +C +C Update XA with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), + $ LDA, Q(I,I), 1, ZERO, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update A(i+1:n,k+i). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,1), LDQ, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, A(1,K+I), 1, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YA(K+I,1), LDYA, ONE, A(I+1,K+I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YA(K+I,NB1), LDYA, ONE, A(I+1,K+I), 1 ) +C +C Apply rotation to [ A(i+1:n,k+i)'; Q(i,i+1:n) ]. +C + CALL DROT( N-I, A(I+1,K+I), 1, Q(I,I+1), LDQ, C, S ) +C +C Update XQ with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ A(I,K+I), LDA, ZERO, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ A(I,K+I+1), LDA, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, A(1,K+I+1), LDA, + $ A(I,K+I+1), LDA, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, + $ A(I,K+I+1), LDA, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) +C +C Update XA with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I+1, ONE, A(I+1,K+I), + $ LDA, A(I,K+I), LDA, ZERO, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ A(I,K+I+1), LDA, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) +C +C Update A(i+1:n,k+i). +C + CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(I+1,K+I), 1 ) +C +C Update XG with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ Q(I,I), 1, ZERO, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) +C +C Update G(k+i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, A(1,K+I), 1, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) +C +C Update XB with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, + $ Q(I,I), 1, ZERO, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, + $ DWORK, 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) +C +C Update B(i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ Q(I,1), LDQ, ONE, B(I,1), LDB ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, A(1,K+I), 1, ONE, B(I,1), LDB ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) +C +C Apply rotation to [ G(k+i,:); B(i,:) ]. +C + CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) +C + DO 100 J = 1, I-1 + YG(K+I,J) = ZERO + 100 CONTINUE + DO 110 J = 1, I-1 + YG(K+I,NB+J) = ZERO + 110 CONTINUE + DO 120 J = 1, I-1 + YA(K+I,J) = ZERO + 120 CONTINUE + DO 130 J = 1, I-1 + YA(K+I,NB+J) = ZERO + 130 CONTINUE +C +C Update XG with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ A(I,K+I), LDA, ZERO, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) +C +C Update G(k+i,:). +C + CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) +C +C Update XB with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, + $ A(I,K+I), LDA, ZERO, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, + $ A(I,K+I+1), LDA, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) +C +C Update B(i,:). +C + CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) +C + A(I,K+I) = TEMP + Q(I,I) = TAUQ + CSL(2*I-1) = C + CSL(2*I) = S +C +C Transform first rows of Q and B. +C + ALPHA = Q(I,I+1) + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) + Q(I,I+1) = ONE + TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) + CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) + TEMP = B(I,K+I+1) + CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) + S = -S + CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) + TEMP = B(I,K+I+1) + B(I,K+I+1) = ONE +C +C Update YB with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), + $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ DWORK, 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) +C +C Update B(i+1:n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) +C +C Update YQ with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ DWORK, 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) +C +C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. +C + CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) + DO 140 J = 1, I + XB(K+I+1,J) = ZERO + 140 CONTINUE + DO 150 J = 1, I + XB(K+I+1,NB+J) = ZERO + 150 CONTINUE +C +C Update YB with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), + $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, + $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, + $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, + $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), + $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) +C +C Update B(i+1:n,k+i+1). +C + CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) +C +C Update YQ with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, + $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) +C +C Update YA with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, + $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C +C Update A(i+1,1:k+n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XA(I+1,1), LDXA, ONE, A(I+1,K+I+1), LDA ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(I+1,K+I+1), LDA ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ Q(1,I+1), 1, ONE, A(I+1,1), LDA ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ B(1,K+I+1), 1, ONE, A(I+1,1), LDA ) +C +C Update YG with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, + $ DWORK, 1, ONE, YG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) + DO 160 J = 1, I + XG(K+I+1,J) = ZERO + 160 CONTINUE + DO 170 J = 1, I + XG(K+I+1,NB+J) = ZERO + 170 CONTINUE +C +C Apply rotation to [ A(i+1,1:k+n)', G(1:k+n,k+i+1) ]. +C + CALL DROT( K+N, A(I+1,1), LDA, G(1,K+I+1), 1, C, S ) +C +C Update YA with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, K+N, ONE, A(I+1,1), LDA, + $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) +C +C Update A(i+1,1:k+n). +C + CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(I+1,1), LDA ) +C +C Update YG with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I, N-I, ONE, A(1,K+I+1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) +C + B(I,K+I+1) = TEMP + Q(I,I+1) = TAUQ + CSR(2*I-1) = C + CSR(2*I) = S + 180 CONTINUE +C + ELSE IF ( LTRB ) THEN + DO 270 I = 1, NB +C +C Transform first columns of A and Q. See routine MB04TS. +C + ALPHA = Q(I,I) + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) + Q(I,I) = ONE + TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) + CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) + TEMP = A(K+I,I) + CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) + CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) + TEMP = A(K+I,I) + A(K+I,I) = ONE +C +C Update XQ with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, + $ Q(I,I), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, + $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) +C +C Update XA with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, + $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update A(k+i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) +C +C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. +C + CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) +C +C Update XQ with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, + $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) +C +C Update XA with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, + $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) +C +C Update A(k+i,i+1:n). +C + CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) +C +C Update XG with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ Q(I,I), 1, ZERO, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) +C +C Update G(k+i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) +C +C Update XB with first Householder reflection. +C + CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, + $ Q(I,I), 1, ZERO, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, + $ DWORK, 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) +C +C Update B(:,i). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ Q(I,1), LDQ, ONE, B(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, A(K+I,1), LDA, ONE, B(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YB(I,1), LDYB, ONE, B(K+I+1,I), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ YB(I,NB1), LDYB, ONE, B(K+I+1,I), 1 ) +C +C Apply rotation to [ G(k+i,:); B(:,i)' ]. +C + CALL DROT( K+N, G(K+I,1), LDG, B(1,I), 1, C, S ) +C + DO 190 J = 1, I-1 + YG(K+I,J) = ZERO + 190 CONTINUE + DO 200 J = 1, I-1 + YG(K+I,NB+J) = ZERO + 200 CONTINUE + DO 210 J = 1, I-1 + YA(K+I,J) = ZERO + 210 CONTINUE + DO 220 J = 1, I-1 + YA(K+I,NB+J) = ZERO + 220 CONTINUE +C +C Update XG with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) +C +C Update G(k+i,:). +C + CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) +C +C Update XB with second Householder reflection. +C + CALL DGEMV( 'No Transpose', K+N, N-I+1, ONE, B(1,I), LDB, + $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) +C +C Update B(:,i). +C + CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(1,I), 1 ) +C + A(K+I,I) = TEMP + Q(I,I) = TAUQ + CSL(2*I-1) = C + CSL(2*I) = S +C +C Transform first rows of Q and B. +C + ALPHA = Q(I,I+1) + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) + Q(I,I+1) = ONE + TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) + CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(K+I+1,I), 1 ) + TEMP = B(K+I+1,I) + CALL DLARTG( TEMP, ALPHA, C, S, B(K+I+1,I) ) + S = -S + CALL DLARFG( N-I, B(K+I+1,I), B(K+I+2,I), 1, TAUR(I) ) + TEMP = B(K+I+1,I) + B(K+I+1,I) = ONE +C +C Update YB with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), + $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ DWORK, 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, B(K+I+1,1), LDB, + $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) +C +C Update B(k+i+1,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XB(K+I+1,1), LDXB, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XB(K+I+1,NB1), LDXB, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ Q(1,I+1), 1, ONE, B(K+I+1,I+1), LDB ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, B(K+I+1,1), LDB, ONE, B(K+I+1,I+1), LDB ) +C +C Update YQ with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ DWORK, 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, B(K+I+1,1), LDB, ONE, Q(I+1,I+1), 1 ) +C +C Apply rotation to [ Q(i+1:n,i+1), B(k+i+1,i+1:n)' ]. +C + CALL DROT( N-I, Q(I+1,I+1), 1, B(K+I+1,I+1), LDB, C, S ) + DO 230 J = 1, I + XB(K+I+1,J) = ZERO + 230 CONTINUE + DO 240 J = 1, I + XB(K+I+1,NB+J) = ZERO + 240 CONTINUE +C +C Update YB with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I, N-I, ONE, B(K+I+1,I+1), + $ LDB, B(K+I+1,I), 1, ZERO, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, + $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, + $ B(K+I+2,I), 1, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, + $ B(K+I+2,I), 1, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, B(K+I+2,1), + $ LDQ, B(K+I+2,I), 1, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) +C +C Update B(k+i+1,i+1:n). +C + CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(K+I+1,I+1), LDB ) +C +C Update YQ with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ B(K+I+1,I), 1, ZERO, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, + $ B(K+I+2,I), 1, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) +C +C Update YA with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C +C Update A(1:k+n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ B(K+I+1,1), LDB, ONE, A(1,I+1), 1 ) +C +C Update YG with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, + $ DWORK, 1, ONE, YG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ B(K+I+1,1), LDB, ONE, G(1,K+I+1), 1 ) + DO 250 J = 1, I + XG(K+I+1,J) = ZERO + 250 CONTINUE + DO 260 J = 1, I + XG(K+I+1,NB+J) = ZERO + 260 CONTINUE +C +C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. +C + CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) +C +C Update YA with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ B(K+I+1,I), 1, ZERO, YA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) +C +C Update A(1:k+n,i+1). +C + CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) +C +C Update YG with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ B(K+I+1,I), 1, ZERO, YG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, + $ B(K+I+2,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) +C + B(K+I+1,I) = TEMP + Q(I,I+1) = TAUQ + CSR(2*I-1) = C + CSR(2*I) = S + 270 CONTINUE +C + ELSE + DO 360 I = 1, NB +C +C Transform first columns of A and Q. See routine MB04TS. +C + ALPHA = Q(I,I) + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, TAUQ ) + Q(I,I) = ONE + TEMP = -TAUQ*DDOT( N-I+1, Q(I,I), 1, A(K+I,I), 1 ) + CALL DAXPY( N-I+1, TEMP, Q(I,I), 1, A(K+I,I), 1 ) + TEMP = A(K+I,I) + CALL DLARTG( TEMP, ALPHA, C, S, A(K+I,I) ) + CALL DLARFG( N-I+1, A(K+I,I), A(K+I+1,I), 1, TAUL(I) ) + TEMP = A(K+I,I) + A(K+I,I) = ONE +C +C Update XQ with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ Q(I,I), 1, ZERO, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Q(I,1), LDQ, + $ Q(I,I), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, A(K+I,1), LDA, + $ Q(I,I), 1, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB+1), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YQ(I,NB1), LDYQ, + $ Q(I,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,1), LDQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(K+I,1), LDA, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YQ(I,1), LDYQ, ONE, Q(I,I+1), LDQ ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YQ(I,NB1), LDYQ, ONE, Q(I,I+1), LDQ ) +C +C Update XA with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, + $ Q(I,I), 1, ZERO, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB+1), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YA(K+I,NB1), LDYA, + $ Q(I,I), 1, ZERO, XA(1,I), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update A(k+i,i+1:n). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,1), LDQ, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, A(K+I,1), LDA, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YA(K+I,1), LDYA, ONE, A(K+I,I+1), LDA ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YA(K+I,NB1), LDYA, ONE, A(K+I,I+1), LDA ) +C +C Apply rotation to [ A(k+i,i+1:n); Q(i,i+1:n) ]. +C + CALL DROT( N-I, A(K+I,I+1), LDA, Q(I,I+1), LDQ, C, S ) +C +C Update XQ with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, Q(I,I+1), LDQ, + $ A(K+I,I), 1, ZERO, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ A(K+I+1,I), 1, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ DWORK(NB2+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ A(K+I+1,I), 1, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB3+1), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YQ(I+1,NB1), LDYQ, + $ A(K+I+1,I), 1, ZERO, XQ(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XQ(1,I+NB), 1, ONE, XQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XQ(I+1,I+NB), 1 ) +C +C Update Q(i,i+1:n). +C + CALL DAXPY( N-I, ONE, XQ(I+1,I+NB), 1, Q(I,I+1), LDQ ) +C +C Update XA with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, N-I, ONE, A(K+I,I+1), LDA, + $ A(K+I,I), 1, ZERO, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ DWORK(NB2+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB3+1), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ A(K+I+1,I), 1, ZERO, XA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ XA(1,I+NB), 1, ONE, XA(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUL(I), XA(I+1,I+NB), 1 ) +C +C Update A(k+i,i+1:n). +C + CALL DAXPY( N-I, ONE, XA(I+1,I+NB), 1, A(K+I,I+1), LDA ) +C +C Update XG with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ Q(I,I), 1, ZERO, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB+1), 1, ONE, XG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YG(K+I,NB1), LDYG, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XG(1,I), 1 ) +C +C Update G(k+i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ Q(I,1), LDQ, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, A(K+I,1), LDA, ONE, G(K+I,1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YG(K+I,1), LDYG, ONE, G(K+I,K+I+1), LDG ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YG(K+I,NB1), LDYG, ONE, G(K+I,K+I+1), LDG ) +C +C Update XB with first Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, + $ Q(I,I), 1, ZERO, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB, LDXB, + $ DWORK, 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB+1), 1, ONE, XB(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, YB(I,NB1), LDYB, + $ Q(I,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, XB(1,I), 1 ) +C +C Update B(i,:). +C + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ Q(I,1), LDQ, ONE, B(I,1), LDB ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, A(K+I,1), LDA, ONE, B(I,1), LDB ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ YB(I,1), LDYB, ONE, B(I,K+I+1), LDB ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ YB(I,NB1), LDYB, ONE, B(I,K+I+1), LDB ) +C +C Apply rotation to [ G(k+i,:); B(i,:) ]. +C + CALL DROT( K+N, G(K+I,1), LDG, B(I,1), LDB, C, S ) +C + DO 280 J = 1, I-1 + YG(K+I,J) = ZERO + 280 CONTINUE + DO 290 J = 1, I-1 + YG(K+I,NB+J) = ZERO + 290 CONTINUE + DO 300 J = 1, I-1 + YA(K+I,J) = ZERO + 300 CONTINUE + DO 310 J = 1, I-1 + YA(K+I,NB+J) = ZERO + 310 CONTINUE +C +C Update XG with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, G(K+I,1), LDG, + $ A(K+I,I), 1, ZERO, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK(NB2+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB3+1), 1, ONE, XG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,1), LDYG, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YG(K+I+1,NB1), LDYG, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XG(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XG(1,I+NB), 1 ) +C +C Update G(k+i,:). +C + CALL DAXPY( K+N, ONE, XG(1,I+NB), 1, G(K+I,1), LDG ) +C +C Update XB with second Householder reflection. +C + CALL DGEMV( 'Transpose', N-I+1, K+N, ONE, B(I,1), LDB, + $ A(K+I,I), 1, ZERO, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, XB, LDXB, + $ DWORK(NB2+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XB(1,NB1), + $ LDXB, DWORK(NB3+1), 1, ONE, XB(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YB(I+1,NB1), LDYB, + $ A(K+I+1,I), 1, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ DWORK(PDW), 1, ONE, XB(K+I+1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUL(I), XB(1,I+NB), 1 ) +C +C Update B(i,:). +C + CALL DAXPY( K+N, ONE, XB(1,I+NB), 1, B(I,1), LDB ) +C + A(K+I,I) = TEMP + Q(I,I) = TAUQ + CSL(2*I-1) = C + CSL(2*I) = S +C +C Transform first rows of Q and B. +C + ALPHA = Q(I,I+1) + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, TAUQ ) + Q(I,I+1) = ONE + TEMP = -TAUQ*DDOT( N-I, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) + CALL DAXPY( N-I, TEMP, Q(I,I+1), LDQ, B(I,K+I+1), LDB ) + TEMP = B(I,K+I+1) + CALL DLARTG( TEMP, ALPHA, C, S, B(I,K+I+1) ) + S = -S + CALL DLARFG( N-I, B(I,K+I+1), B(I,K+I+2), LDB, TAUR(I) ) + TEMP = B(I,K+I+1) + B(I,K+I+1) = ONE +C +C Update YB with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), + $ LDB, Q(I,I+1), LDQ, ZERO, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XB(K+I+1,NB1), LDXB, + $ Q(I,I+1), LDQ, ZERO, YB(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YB(1,I), 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, Q(1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,1), LDYB, + $ DWORK, 1, ONE, YB(I+1,I), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, ONE, B(1,K+I+1), LDB, + $ Q(I,I+1), LDQ, ZERO, DWORK(NB+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB+1), 1, ONE, YB(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YB(I+1,I), 1 ) +C +C Update B(i+1:n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XB(K+I+1,1), LDXB, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XB(K+I+1,NB1), LDXB, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ Q(1,I+1), 1, ONE, B(I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, B(1,K+I+1), 1, ONE, B(I+1,K+I+1), 1 ) +C +C Update YQ with first Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ Q(I,I+1), LDQ, ZERO, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XQ(I+1,NB1), LDXQ, + $ Q(I,I+1), LDQ, ZERO, YQ(1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YQ(1,I), 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,1), LDYQ, + $ DWORK, 1, ONE, YQ(I+1,I), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB+1), 1, ONE, YQ(I+1,I), 1 ) + CALL DSCAL( N-I, -TAUQ, YQ(I+1,I), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XQ(I+1,1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ Q(1,I+1), 1, ONE, Q(I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, B(1,K+I+1), 1, ONE, Q(I+1,I+1), 1 ) +C +C Apply rotation to [ Q(i+1:n,i+1), B(i+1:n,k+i+1) ]. +C + CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,K+I+1), 1, C, S ) + DO 320 J = 1, I + XB(K+I+1,J) = ZERO + 320 CONTINUE + DO 330 J = 1, I + XB(K+I+1,NB+J) = ZERO + 330 CONTINUE +C +C Update YB with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, B(I+1,K+I+1), + $ LDB, B(I,K+I+1), LDB, ZERO, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,1), LDXB, + $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XB(K+I+2,NB1), LDXB, + $ B(I,K+I+2), LDB, ZERO, YB(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YB(1,I+NB), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I, N-I-1, ONE, Q(1,I+2), LDQ, + $ B(I,K+I+2), LDB, ZERO, DWORK(NB2+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YB(I+1,1), LDYB, + $ DWORK(NB2+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I-1, ONE, B(1,K+I+2), + $ LDQ, B(I,K+I+2), LDB, ZERO, DWORK(NB3+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YB(I+1,NB1), + $ LDYB, DWORK(NB3+1), 1, ONE, YB(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YB(I+1,I+NB), 1 ) +C +C Update B(i+1:n,k+i+1). +C + CALL DAXPY( N-I, ONE, YB(I+1,I+NB), 1, B(I+1,K+I+1), 1 ) +C +C Update YQ with second Householder reflection. +C + CALL DGEMV( 'No transpose', N-I, N-I, ONE, Q(I+1,I+1), LDQ, + $ B(I,K+I+1), LDB, ZERO, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,NB1), LDXQ, + $ B(I,K+I+2), LDB, ZERO, YQ(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ YQ(1,I+NB), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, YQ(I+1,1), LDYQ, + $ DWORK(NB2+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, ONE, YQ(I+1,NB1), + $ LDYQ, DWORK(NB3+1), 1, ONE, YQ(I+1,I+NB), 1 ) + CALL DSCAL( N-I, -TAUR(I), YQ(I+1,I+NB), 1 ) +C +C Update Q(i+1:n,i+1). +C + CALL DAXPY( N-I, ONE, YQ(I+1,I+NB), 1, Q(I+1,I+1), 1 ) +C +C Update YA with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ Q(I,I+1), LDQ, ZERO, YA(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XA(I+1,NB1), LDXA, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB+1), 1, ONE, YA(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C +C Update A(1:k+n,i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ Q(1,I+1), 1, ONE, A(1,I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ B(1,K+I+1), 1, ONE, A(1,I+1), 1 ) +C +C Update YG with first Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ Q(I,I+1), LDQ, ZERO, YG(1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'Transpose', N-I, I, ONE, XG(K+I+1,NB1), LDXG, + $ Q(I,I+1), LDQ, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG, LDYG, + $ DWORK, 1, ONE, YG(1,I), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB+1), 1, ONE, YG(1,I), 1 ) + CALL DSCAL( K+N, -TAUQ, YG(1,I), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ XG(K+I+1,1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, G(K+I+1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ Q(1,I+1), 1, ONE, G(1,K+I+1), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ B(1,K+I+1), 1, ONE, G(1,K+I+1), 1 ) + DO 340 J = 1, I + XG(K+I+1,J) = ZERO + 340 CONTINUE + DO 350 J = 1, I + XG(K+I+1,NB+J) = ZERO + 350 CONTINUE +C +C Apply rotation to [ A(1:k+n,i+1), G(1:k+n,k+i+1) ]. +C + CALL DROT( K+N, A(1,I+1), 1, G(1,K+I+1), 1, C, S ) +C +C Update YA with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ B(I,K+I+1), LDB, ZERO, YA(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,NB1), LDXA, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YA(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK(NB2+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB3+1), 1, ONE, YA(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YA(1,I+NB), 1 ) +C +C Update A(1:k+n,i+1). +C + CALL DAXPY( K+N, ONE, YA(1,I+NB), 1, A(1,I+1), 1 ) +C +C Update YG with second Householder reflection. +C + CALL DGEMV( 'No transpose', K+N, N-I, ONE, G(1,K+I+1), LDG, + $ B(I,K+I+1), LDB, ZERO, YG(1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), LDXG, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, Q(I+1,1), LDQ, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,NB1), LDXG, + $ B(I,K+I+2), LDB, ZERO, DWORK(PDW), 1 ) + CALL DGEMV( 'No transpose', N-I, I, ONE, A(K+I+1,1), LDA, + $ DWORK(PDW), 1, ONE, YG(K+I+1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I, ONE, YG, LDYG, + $ DWORK(NB2+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YG(1,NB1), LDYG, + $ DWORK(NB3+1), 1, ONE, YG(1,I+NB), 1 ) + CALL DSCAL( K+N, -TAUR(I), YG(1,I+NB), 1 ) +C +C Update G(1:k+n,k+i+1). +C + CALL DAXPY( K+N, ONE, YG(1,I+NB), 1, G(1,K+I+1), 1 ) +C + B(I,K+I+1) = TEMP + Q(I,I+1) = TAUQ + CSR(2*I-1) = C + CSR(2*I) = S + 360 CONTINUE + END IF +C + RETURN +C *** Last line of MB03XU *** + END diff --git a/mex/sources/libslicot/MB03YA.f b/mex/sources/libslicot/MB03YA.f new file mode 100644 index 000000000..0a87c7c30 --- /dev/null +++ b/mex/sources/libslicot/MB03YA.f @@ -0,0 +1,297 @@ + SUBROUTINE MB03YA( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, + $ POS, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To annihilate one or two entries on the subdiagonal of the +C Hessenberg matrix A for dealing with zero elements on the diagonal +C of the triangular matrix B. +C +C MB03YA is an auxiliary routine called by SLICOT Library routines +C MB03XP and MB03YD. +C +C ARGUMENTS +C +C Mode Parameters +C +C WANTT LOGICAL +C Indicates whether the user wishes to compute the full +C Schur form or the eigenvalues only, as follows: +C = .TRUE. : Compute the full Schur form; +C = .FALSE.: compute the eigenvalues only. +C +C WANTQ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Q as follows: +C = .TRUE. : The matrix Q is updated; +C = .FALSE.: the matrix Q is not required. +C +C WANTZ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Z as follows: +C = .TRUE. : The matrix Z is updated; +C = .FALSE.: the matrix Z is not required. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that the matrices A and B are already +C (quasi) upper triangular in rows and columns 1:ILO-1 and +C IHI+1:N. The routine works primarily with the submatrices +C in rows and columns ILO to IHI, but applies the +C transformations to all the rows and columns of the +C matrices A and B, if WANTT = .TRUE.. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C ILOQ (input) INTEGER +C IHIQ (input) INTEGER +C Specify the rows of Q and Z to which transformations +C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., +C respectively. +C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. +C +C POS (input) INTEGER +C The position of the zero element on the diagonal of B. +C ILO <= POS <= IHI. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper Hessenberg matrix A. +C On exit, the leading N-by-N part of this array contains +C the updated matrix A where A(POS,POS-1) = 0, if POS > ILO, +C and A(POS+1,POS) = 0, if POS < IHI. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain an upper triangular matrix B with B(POS,POS) = 0. +C On exit, the leading N-by-N part of this array contains +C the updated upper triangular matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if WANTQ = .TRUE., then the leading N-by-N part +C of this array must contain the current matrix Q of +C transformations accumulated by MB03XP. +C On exit, if WANTQ = .TRUE., then the leading N-by-N part +C of this array contains the matrix Q updated in the +C submatrix Q(ILOQ:IHIQ,ILO:IHI). +C If WANTQ = .FALSE., Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= 1. +C If WANTQ = .TRUE., LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if WANTZ = .TRUE., then the leading N-by-N part +C of this array must contain the current matrix Z of +C transformations accumulated by MB03XP. +C On exit, if WANTZ = .TRUE., then the leading N-by-N part +C of this array contains the matrix Z updated in the +C submatrix Z(ILOQ:IHIQ,ILO:IHI). +C If WANTZ = .FALSE., Z is not referenced. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= 1. +C If WANTZ = .TRUE., LDZ >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The method is illustrated by Wilkinson diagrams for N = 5, +C POS = 3: +C +C [ x x x x x ] [ x x x x x ] +C [ x x x x x ] [ o x x x x ] +C A = [ o x x x x ], B = [ o o o x x ]. +C [ o o x x x ] [ o o o x x ] +C [ o o o x x ] [ o o o o x ] +C +C First, a QR factorization is applied to A(1:3,1:3) and the +C resulting nonzero in the updated matrix B is immediately +C annihilated by a Givens rotation acting on columns 1 and 2: +C +C [ x x x x x ] [ x x x x x ] +C [ x x x x x ] [ o x x x x ] +C A = [ o o x x x ], B = [ o o o x x ]. +C [ o o x x x ] [ o o o x x ] +C [ o o o x x ] [ o o o o x ] +C +C Secondly, an RQ factorization is applied to A(4:5,4:5) and the +C resulting nonzero in the updated matrix B is immediately +C annihilated by a Givens rotation acting on rows 4 and 5: +C +C [ x x x x x ] [ x x x x x ] +C [ x x x x x ] [ o x x x x ] +C A = [ o o x x x ], B = [ o o o x x ]. +C [ o o o x x ] [ o o o x x ] +C [ o o o x x ] [ o o o o x ] +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. +C The periodic Schur decomposition: Algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**2) floating point operations and is +C backward stable. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLADFB). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + LOGICAL WANTQ, WANTT, WANTZ + INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, LDZ, + $ N, POS +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I1, I2, J, NQ + DOUBLE PRECISION CS, SN, TEMP +C .. External Subroutines .. + EXTERNAL DLARTG, DROT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + NQ = IHIQ - ILOQ + 1 + IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -6 + ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN + INFO = -7 + ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN + INFO = -8 + ELSE IF ( POS.LT.ILO .OR. POS.GT.IHI ) THEN + INFO = -9 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN + INFO = -15 + ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN + INFO = -17 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03YA', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + IF ( WANTT ) THEN + I1 = 1 + I2 = N + ELSE + I1 = ILO + I2 = IHI + END IF +C +C Apply a zero-shifted QR step. +C + DO 10 J = ILO, POS-1 + TEMP = A(J,J) + CALL DLARTG( TEMP, A(J+1,J), CS, SN, A(J,J) ) + A(J+1,J) = ZERO + CALL DROT( I2-J, A(J,J+1), LDA, A(J+1,J+1), LDA, CS, SN ) + CALL DROT( MIN(J,POS-2)-I1+2, B(I1,J), 1, B(I1,J+1), 1, CS, + $ SN ) + IF ( WANTQ ) + $ CALL DROT( NQ, Q(ILOQ,J), 1, Q(ILOQ,J+1), 1, CS, SN ) + 10 CONTINUE + DO 20 J = ILO, POS-2 + TEMP = B(J,J) + CALL DLARTG( TEMP, B(J+1,J), CS, SN, B(J,J) ) + B(J+1,J) = ZERO + CALL DROT( I2-J, B(J,J+1), LDB, B(J+1,J+1), LDB, CS, SN ) + CALL DROT( J-I1+2, A(I1,J), 1, A(I1,J+1), 1, CS, SN ) + IF ( WANTZ ) + $ CALL DROT( NQ, Z(ILOQ,J), 1, Z(ILOQ,J+1), 1, CS, SN ) + 20 CONTINUE +C +C Apply a zero-shifted RQ step. +C + DO 30 J = IHI, POS+1, -1 + TEMP = A(J,J) + CALL DLARTG( TEMP, A(J,J-1), CS, SN, A(J,J) ) + A(J,J-1) = ZERO + SN = -SN + CALL DROT( J-I1, A(I1,J-1), 1, A(I1,J), 1, CS, SN ) + CALL DROT( I2 - MAX( J-1,POS+1 ) + 1, B(J-1,MAX( J-1,POS+1 )), + $ LDB, B(J,MAX(J-1,POS+1)), LDB, CS, SN ) + IF ( WANTZ ) + $ CALL DROT( NQ, Z(ILOQ,J-1), 1, Z(ILOQ,J), 1, CS, SN ) + 30 CONTINUE + DO 40 J = IHI, POS+2, -1 + TEMP = B(J,J) + CALL DLARTG( TEMP, B(J,J-1), CS, SN, B(J,J) ) + B(J,J-1) = ZERO + SN = -SN + CALL DROT( J-I1, B(I1,J-1), 1, B(I1,J), 1, CS, SN ) + CALL DROT( I2-J+2, A(J-1,J-1), LDA, A(J,J-1), LDA, CS, SN ) + IF ( WANTQ ) + $ CALL DROT( NQ, Q(ILOQ,J-1), 1, Q(ILOQ,J), 1, CS, SN ) + 40 CONTINUE + RETURN +C *** Last line of MB03YA *** + END diff --git a/mex/sources/libslicot/MB03YD.f b/mex/sources/libslicot/MB03YD.f new file mode 100644 index 000000000..e99078cdb --- /dev/null +++ b/mex/sources/libslicot/MB03YD.f @@ -0,0 +1,540 @@ + SUBROUTINE MB03YD( WANTT, WANTQ, WANTZ, N, ILO, IHI, ILOQ, IHIQ, + $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, + $ BETA, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To deal with small subtasks of the product eigenvalue problem. +C +C MB03YD is an auxiliary routine called by SLICOT Library routine +C MB03XP. +C +C ARGUMENTS +C +C Mode Parameters +C +C WANTT LOGICAL +C Indicates whether the user wishes to compute the full +C Schur form or the eigenvalues only, as follows: +C = .TRUE. : Compute the full Schur form; +C = .FALSE.: compute the eigenvalues only. +C +C WANTQ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Q as follows: +C = .TRUE. : The matrix Q is updated; +C = .FALSE.: the matrix Q is not required. +C +C WANTZ LOGICAL +C Indicates whether or not the user wishes to accumulate +C the matrix Z as follows: +C = .TRUE. : The matrix Z is updated; +C = .FALSE.: the matrix Z is not required. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and B. N >= 0. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that the matrices A and B are already +C (quasi) upper triangular in rows and columns 1:ILO-1 and +C IHI+1:N. The routine works primarily with the submatrices +C in rows and columns ILO to IHI, but applies the +C transformations to all the rows and columns of the +C matrices A and B, if WANTT = .TRUE.. +C 1 <= ILO <= max(1,N); min(ILO,N) <= IHI <= N. +C +C ILOQ (input) INTEGER +C IHIQ (input) INTEGER +C Specify the rows of Q and Z to which transformations +C must be applied if WANTQ = .TRUE. and WANTZ = .TRUE., +C respectively. +C 1 <= ILOQ <= ILO; IHI <= IHIQ <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper Hessenberg matrix A. +C On exit, if WANTT = .TRUE., the leading N-by-N part of +C this array is upper quasi-triangular in rows and columns +C ILO:IHI. +C If WANTT = .FALSE., the diagonal elements and 2-by-2 +C diagonal blocks of A will be correct, but the remaining +C parts of A are unspecified on exit. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular matrix B. +C On exit, if WANTT = .TRUE., the leading N-by-N part of +C this array contains the transformed upper triangular +C matrix. 2-by-2 blocks in B corresponding to 2-by-2 blocks +C in A will be reduced to positive diagonal form. (I.e., if +C A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) +C and B(j+1,j+1) will be positive.) +C If WANTT = .FALSE., the elements corresponding to diagonal +C elements and 2-by-2 diagonal blocks in A will be correct, +C but the remaining parts of B are unspecified on exit. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if WANTQ = .TRUE., then the leading N-by-N part +C of this array must contain the current matrix Q of +C transformations accumulated by MB03XP. +C On exit, if WANTQ = .TRUE., then the leading N-by-N part +C of this array contains the matrix Q updated in the +C submatrix Q(ILOQ:IHIQ,ILO:IHI). +C If WANTQ = .FALSE., Q is not referenced. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= 1. +C If WANTQ = .TRUE., LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if WANTZ = .TRUE., then the leading N-by-N part +C of this array must contain the current matrix Z of +C transformations accumulated by MB03XP. +C On exit, if WANTZ = .TRUE., then the leading N-by-N part +C of this array contains the matrix Z updated in the +C submatrix Z(ILOQ:IHIQ,ILO:IHI). +C If WANTZ = .FALSE., Z is not referenced. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= 1. +C If WANTZ = .TRUE., LDZ >= MAX(1,N). +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C The i-th (ILO <= i <= IHI) computed eigenvalue is given +C by BETA(I) * ( ALPHAR(I) + sqrt(-1)*ALPHAI(I) ). If two +C eigenvalues are computed as a complex conjugate pair, +C they are stored in consecutive elements of ALPHAR, ALPHAI +C and BETA. If WANTT = .TRUE., the eigenvalues are stored in +C the same order as on the diagonals of the Schur forms of +C A and B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = -19, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then MB03YD failed to compute the Schur +C form in a total of 30*(IHI-ILO+1) iterations; +C elements i+1:n of ALPHAR, ALPHAI and BETA contain +C successfully computed eigenvalues. +C +C METHOD +C +C The implemented algorithm is a double-shift version of the +C periodic QR algorithm described in [1,3] with some minor +C modifications [2]. The eigenvalues are computed via an implicit +C complex single shift algorithm. +C +C REFERENCES +C +C [1] Bojanczyk, A.W., Golub, G.H., and Van Dooren, P. +C The periodic Schur decomposition: Algorithms and applications. +C Proc. of the SPIE Conference (F.T. Luk, Ed.), 1770, pp. 31-42, +C 1992. +C +C [2] Kressner, D. +C An efficient and reliable implementation of the periodic QZ +C algorithm. Proc. of the IFAC Workshop on Periodic Control +C Systems, pp. 187-192, 2001. +C +C [3] Van Loan, C. +C Generalized Singular Values with Algorithms and Applications. +C Ph. D. Thesis, University of Michigan, 1973. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**3) floating point operations and is +C backward stable. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPQR). +C +C KEYWORDS +C +C Eigenvalue, eigenvalue decomposition, Hessenberg form, orthogonal +C transformation, (periodic) Schur form +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + LOGICAL WANTQ, WANTT, WANTZ + INTEGER IHI, IHIQ, ILO, ILOQ, INFO, LDA, LDB, LDQ, + $ LDWORK, LDZ, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), + $ BETA(*), DWORK(*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I, I1, I2, ITN, ITS, K, KK, L, NH, NQ, NR + DOUBLE PRECISION ALPHA, BETAX, CS1, CS2, CS3, DELTA, GAMMA, + $ OVFL, SMLNUM, SN1, SN2, SN3, TAUV, TAUW, + $ TEMP, TST, ULP, UNFL +C .. Local Arrays .. + INTEGER ISEED(4) + DOUBLE PRECISION V(3), W(3) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLARFG, DLARFX, DLARNV, DLARTG, + $ DROT, MB03YA, MB03YT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + NH = IHI - ILO + 1 + NQ = IHIQ - ILOQ + 1 + IF ( N.LT.0 ) THEN + INFO = -4 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF ( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -6 + ELSE IF ( ILOQ.LT.1 .OR. ILOQ.GT.ILO ) THEN + INFO = -7 + ELSE IF ( IHIQ.LT.IHI .OR. IHIQ.GT.N ) THEN + INFO = -8 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.N ) THEN + INFO = -14 + ELSE IF ( LDZ.LT.1 .OR. WANTZ .AND. LDZ.LT.N ) THEN + INFO = -16 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -21 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03YD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C +C Set machine-dependent constants for the stopping criterion. +C + UNFL = DLAMCH( 'Safe minimum' ) + OVFL = ONE / UNFL + CALL DLABAD( UNFL, OVFL ) + ULP = DLAMCH( 'Precision' ) + SMLNUM = UNFL*( NH / ULP ) +C +C I1 and I2 are the indices of the first rows and last columns of +C A and B to which transformations must be applied. +C + I1 = 1 + I2 = N + ISEED(1) = 1 + ISEED(2) = 0 + ISEED(3) = 0 + ISEED(4) = 1 +C +C ITN is the maximal number of QR iterations. +C + ITN = 30*NH +C +C Main loop. Eigenvalues I+1:IHI have converged. Either L = ILO +C or A(L,L-1) is negligible. +C + I = IHI + 10 CONTINUE + L = ILO + IF ( I.LT.ILO ) + $ GO TO 120 +C +C Perform periodic QR iteration on rows and columns ILO to I of A +C and B until a submatrix of order 1 or 2 splits off at the bottom. +C + DO 70 ITS = 0, ITN +C +C Look for deflations in A. +C + DO 20 K = I, L + 1, -1 + TST = ABS( A(K-1,K-1) ) + ABS( A(K,K) ) + IF ( TST.EQ.ZERO ) + $ TST = DLANHS( '1', I-L+1, A(L,L), LDA, DWORK ) + IF ( ABS( A(K,K-1) ).LE.MAX( ULP*TST, SMLNUM ) ) + $ GO TO 30 + 20 CONTINUE + 30 CONTINUE +C +C Look for deflation in B if problem size is greater than 1. +C + IF ( I-K.GE.1 ) THEN + DO 40 KK = I, K, -1 + IF ( KK.EQ.I ) THEN + TST = ABS( B(KK-1,KK) ) + ELSE IF ( KK.EQ.K ) THEN + TST = ABS( B(KK,KK+1) ) + ELSE + TST = ABS( B(KK-1,KK) ) + ABS( B(KK,KK+1) ) + END IF + IF ( TST.EQ.ZERO ) + $ TST = DLANHS( '1', I-K+1, B(K,K), LDB, DWORK ) + IF ( ABS( B(KK,KK) ).LE.MAX( ULP*TST, SMLNUM ) ) + $ GO TO 50 + 40 CONTINUE + ELSE + KK = K-1 + END IF + 50 CONTINUE + IF ( KK.GE.K ) THEN +C +C B has an element close to zero at position (KK,KK). +C + B(KK,KK) = ZERO + CALL MB03YA( WANTT, WANTQ, WANTZ, N, K, I, ILOQ, IHIQ, KK, + $ A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO ) + K = KK+1 + END IF + L = K + IF( L.GT.ILO ) THEN +C +C A(L,L-1) is negligible. +C + A(L,L-1) = ZERO + END IF +C +C Exit from loop if a submatrix of order 1 or 2 has split off. +C + IF ( L.GE.I-1 ) + $ GO TO 80 +C +C The active submatrices are now in rows and columns L:I. +C + IF ( .NOT.WANTT ) THEN + I1 = L + I2 = I + END IF + IF ( ITS.EQ.10.OR.ITS.EQ.20 ) THEN +C +C Exceptional shift. The first column of the shift polynomial +C is a pseudo-random vector. +C + CALL DLARNV( 3, ISEED, 3, V ) + ELSE +C +C The implicit double shift is constructed via a partial +C product QR factorization [2]. +C + CALL DLARTG( B(L,L), B(I,I), CS2, SN2, TEMP ) + CALL DLARTG( TEMP, B(I-1,I), CS1, SN1, ALPHA ) +C + ALPHA = A(L,L)*CS2 - A(I,I)*SN2 + BETAX = CS1*( CS2*A(L+1,L) ) + GAMMA = CS1*( SN2*A(I-1,I) ) + SN1*A(I-1,I-1) + ALPHA = ALPHA*CS1 - A(I,I-1)*SN1 + CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) +C + CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) + ALPHA = CS2 + GAMMA = ( A(I-1,I-1)*CS1 )*CS2 + A(I,I-1)*SN2 + DELTA = ( A(I-1,I-1)*SN1 )*CS2 + CALL DLARTG( GAMMA, DELTA, CS3, SN3, TEMP ) + CALL DLARTG( ALPHA, TEMP, CS2, SN2, ALPHA ) +C + ALPHA = ( B(L,L)*CS1 + B(L,L+1)*SN1 )*CS2 + BETAX = ( B(L+1,L+1)*SN1 )*CS2 + GAMMA = B(I-1,I-1)*SN2 + CALL DLARTG( ALPHA, BETAX, CS1, SN1, TEMP ) + CALL DLARTG( TEMP, GAMMA, CS2, SN2, ALPHA ) +C + ALPHA = CS1*A(L,L) + SN1*A(L,L+1) + BETAX = CS1*A(L+1,L) + SN1*A(L+1,L+1) + GAMMA = SN1*A(L+2,L+1) +C + V(1) = CS2*ALPHA - SN2*CS3 + V(2) = CS2*BETAX - SN2*SN3 + V(3) = GAMMA*CS2 + END IF +C +C Double-shift QR step +C + DO 60 K = L, I-1 +C + NR = MIN( 3,I-K+1 ) + IF ( K.GT.L ) + $ CALL DCOPY( NR, A(K,K-1), 1, V, 1 ) + CALL DLARFG( NR, V(1), V(2), 1, TAUV ) + IF ( K.GT.L ) THEN + A(K,K-1) = V(1) + A(K+1,K-1) = ZERO + IF ( K.LT.I-1 ) + $ A(K+2,K-1) = ZERO + END IF +C +C Apply reflector V from the right to B in rows I1:min(K+2,I). +C + V(1) = ONE + CALL DLARFX( 'Right', MIN(K+2,I)-I1+1, NR, V, TAUV, B(I1,K), + $ LDB, DWORK ) +C +C Annihilate the introduced nonzeros in the K-th column. +C + CALL DCOPY( NR, B(K,K), 1, W, 1 ) + CALL DLARFG( NR, W(1), W(2), 1, TAUW ) + B(K,K) = W(1) + B(K+1,K) = ZERO + IF ( K.LT.I-1 ) + $ B(K+2,K) = ZERO +C +C Apply reflector W from the left to transform the rows of the +C matrix B in columns K+1:I2. +C + W(1) = ONE + CALL DLARFX( 'Left', NR, I2-K, W, TAUW, B(K,K+1), LDB, + $ DWORK ) +C +C Apply reflector V from the left to transform the rows of the +C matrix A in columns K:I2. +C + CALL DLARFX( 'Left', NR, I2-K+1, V, TAUV, A(K,K), LDA, + $ DWORK ) +C +C Apply reflector W from the right to transform the columns of +C the matrix A in rows I1:min(K+3,I). +C + CALL DLARFX( 'Right', MIN(K+3,I)-I1+1, NR, W, TAUW, A(I1,K), + $ LDA, DWORK ) +C +C Accumulate transformations in the matrices Q and Z. +C + IF ( WANTQ ) + $ CALL DLARFX( 'Right', NQ, NR, V, TAUV, Q(ILOQ,K), LDQ, + $ DWORK ) + IF ( WANTZ ) + $ CALL DLARFX( 'Right', NQ, NR, W, TAUW, Z(ILOQ,K), LDZ, + $ DWORK ) + 60 CONTINUE + 70 CONTINUE +C +C Failure to converge. +C + INFO = I + RETURN +C + 80 CONTINUE +C +C Compute 1-by-1 or 2-by-2 subproblem. +C + IF ( L.EQ.I ) THEN +C +C Standardize B, set ALPHAR, ALPHAI and BETA. +C + IF ( B(I,I).LT.ZERO ) THEN + IF ( WANTT ) THEN + DO 90 K = I1, I + B(K,I) = -B(K,I) + 90 CONTINUE + DO 100 K = I, I2 + A(I,K) = -A(I,K) + 100 CONTINUE + ELSE + B(I,I) = -B(I,I) + A(I,I) = -A(I,I) + END IF + IF ( WANTQ ) THEN + DO 110 K = ILOQ, IHIQ + Q(K,I) = -Q(K,I) + 110 CONTINUE + END IF + END IF + ALPHAR(I) = A(I,I) + ALPHAI(I) = ZERO + BETA(I) = B(I,I) + ELSE IF( L.EQ.I-1 ) THEN +C +C A double block has converged. +C Compute eigenvalues and standardize double block. +C + CALL MB03YT( A(I-1,I-1), LDA, B(I-1,I-1), LDB, ALPHAR(I-1), + $ ALPHAI(I-1), BETA(I-1), CS1, SN1, CS2, SN2 ) +C +C Apply transformation to rest of A and B. +C + IF ( I2.GT.I ) + $ CALL DROT( I2-I, A(I-1,I+1), LDA, A(I,I+1), LDA, CS1, SN1 ) + CALL DROT( I-I1-1, A(I1,I-1), 1, A(I1,I), 1, CS2, SN2 ) + IF ( I2.GT.I ) + $ CALL DROT( I2-I, B(I-1,I+1), LDB, B(I,I+1), LDB, CS2, SN2 ) + CALL DROT( I-I1-1, B(I1,I-1), 1, B(I1,I), 1, CS1, SN1 ) +C +C Apply transformation to rest of Q and Z if desired. +C + IF ( WANTQ ) + $ CALL DROT( NQ, Q(ILOQ,I-1), 1, Q(ILOQ,I), 1, CS1, SN1 ) + IF ( WANTZ ) + $ CALL DROT( NQ, Z(ILOQ,I-1), 1, Z(ILOQ,I), 1, CS2, SN2 ) + END IF +C +C Decrement number of remaining iterations, and return to start of +C the main loop with new value of I. +C + ITN = ITN - ITS + I = L - 1 + GO TO 10 +C + 120 CONTINUE + DWORK(1) = DBLE( MAX( 1, N ) ) + RETURN +C *** Last line of MB03YD *** + END diff --git a/mex/sources/libslicot/MB03YT.f b/mex/sources/libslicot/MB03YT.f new file mode 100644 index 000000000..774b0bdda --- /dev/null +++ b/mex/sources/libslicot/MB03YT.f @@ -0,0 +1,331 @@ + SUBROUTINE MB03YT( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, + $ CSR, SNR ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the periodic Schur factorization of a real 2-by-2 +C matrix pair (A,B) where B is upper triangular. This routine +C computes orthogonal (rotation) matrices given by CSL, SNL and CSR, +C SNR such that +C +C 1) if the pair (A,B) has two real eigenvalues, then +C +C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] +C [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] +C +C [ b11 b12 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] +C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ], +C +C 2) if the pair (A,B) has a pair of complex conjugate eigenvalues, +C then +C +C [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] +C [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] +C +C [ b11 0 ] := [ CSR SNR ] [ b11 b12 ] [ CSL -SNL ] +C [ 0 b22 ] [ -SNR CSR ] [ 0 b22 ] [ SNL CSL ]. +C +C This is a modified version of the LAPACK routine DLAGV2 for +C computing the real, generalized Schur decomposition of a +C two-by-two matrix pencil. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,2) +C On entry, the leading 2-by-2 part of this array must +C contain the matrix A. +C On exit, the leading 2-by-2 part of this array contains +C the matrix A of the pair in periodic Schur form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= 2. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,2) +C On entry, the leading 2-by-2 part of this array must +C contain the upper triangular matrix B. +C On exit, the leading 2-by-2 part of this array contains +C the matrix B of the pair in periodic Schur form. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= 2. +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (2) +C ALPHAI (output) DOUBLE PRECISION array, dimension (2) +C BETA (output) DOUBLE PRECISION array, dimension (2) +C (ALPHAR(k)+i*ALPHAI(k))*BETA(k) are the eigenvalues of the +C pair (A,B), k=1,2, i = sqrt(-1). ALPHAI(1) >= 0. +C +C CSL (output) DOUBLE PRECISION +C The cosine of the first rotation matrix. +C +C SNL (output) DOUBLE PRECISION +C The sine of the first rotation matrix. +C +C CSR (output) DOUBLE PRECISION +C The cosine of the second rotation matrix. +C +C SNR (output) DOUBLE PRECISION +C The sine of the second rotation matrix. +C +C REFERENCES +C +C [1] Van Loan, C. +C Generalized Singular Values with Algorithms and Applications. +C Ph. D. Thesis, University of Michigan, 1973. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAPV2). +C V. Sima, July 2008, May 2009. +C +C KEYWORDS +C +C Eigenvalue, periodic Schur form +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER LDA, LDB + DOUBLE PRECISION CSL, CSR, SNL, SNR +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(2), ALPHAR(2), B(LDB,*), + $ BETA(2) +C .. Local Scalars .. + DOUBLE PRECISION ANORM, BNORM, H1, H2, H3, QQ, R, RR, SAFMIN, + $ SCALE1, SCALE2, T, ULP, WI, WR1, WR2 +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +C .. External Subroutines .. + EXTERNAL DLAG2, DLARTG, DLASV2, DROT +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C +C .. Executable Statements .. +C + SAFMIN = DLAMCH( 'S' ) + ULP = DLAMCH( 'P' ) +C +C Scale A. +C + ANORM = MAX( ABS( A(1,1) ) + ABS( A(2,1) ), + $ ABS( A(1,2) ) + ABS( A(2,2) ), SAFMIN ) + A(1,1) = A(1,1) / ANORM + A(1,2) = A(1,2) / ANORM + A(2,1) = A(2,1) / ANORM + A(2,2) = A(2,2) / ANORM +C +C Scale B. +C + BNORM = MAX( ABS( B(1,1) ), ABS( B(1,2) ) + ABS( B(2,2) ), SAFMIN) + B(1,1) = B(1,1) / BNORM + B(1,2) = B(1,2) / BNORM + B(2,2) = B(2,2) / BNORM +C +C Check if A can be deflated. +C + IF ( ABS( A(2,1) ).LE.ULP ) THEN + CSL = ONE + SNL = ZERO + CSR = ONE + SNR = ZERO + WI = ZERO + A(2,1) = ZERO + B(2,1) = ZERO +C +C Check if B is singular. +C + ELSE IF ( ABS( B(1,1) ).LE.ULP ) THEN + CALL DLARTG( A(2,2), A(2,1), CSR, SNR, T ) + SNR = -SNR + CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) + CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR ) + CSL = ONE + SNL = ZERO + WI = ZERO + A(2,1) = ZERO + B(1,1) = ZERO + B(2,1) = ZERO + ELSE IF( ABS( B(2,2) ).LE.ULP ) THEN + CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) + CSR = ONE + SNR = ZERO + WI = ZERO + CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) + CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) + A(2,1) = ZERO + B(2,1) = ZERO + B(2,2) = ZERO + ELSE +C +C B is nonsingular, first compute the eigenvalues of A / adj(B). +C + R = B(1,1) + B(1,1) = B(2,2) + B(2,2) = R + B(1,2) = -B(1,2) + CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, + $ WI ) +C + IF( WI.EQ.ZERO ) THEN +C +C Two real eigenvalues, compute s*A-w*B. +C + H1 = SCALE1*A(1,1) - WR1*B(1,1) + H2 = SCALE1*A(1,2) - WR1*B(1,2) + H3 = SCALE1*A(2,2) - WR1*B(2,2) +C + RR = DLAPY2( H1, H2 ) + QQ = DLAPY2( SCALE1*A(2,1), H3 ) +C + IF ( RR.GT.QQ ) THEN +C +C Find right rotation matrix to zero 1,1 element of +C (sA - wB). +C + CALL DLARTG( H2, H1, CSR, SNR, T ) +C + ELSE +C +C Find right rotation matrix to zero 2,1 element of +C (sA - wB). +C + CALL DLARTG( H3, SCALE1*A(2,1), CSR, SNR, T ) +C + END IF +C + SNR = -SNR + CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) + CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSR, SNR ) +C +C Compute inf norms of A and B. +C + H1 = MAX( ABS( A(1,1) ) + ABS( A(1,2) ), + $ ABS( A(2,1) ) + ABS( A(2,2) ) ) + H2 = MAX( ABS( B(1,1) ) + ABS( B(1,2) ), + $ ABS( B(2,1) ) + ABS( B(2,2) ) ) +C + IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN +C +C Find left rotation matrix Q to zero out B(2,1). +C + CALL DLARTG( B(1,1), B(2,1), CSL, SNL, R ) +C + ELSE +C +C Find left rotation matrix Q to zero out A(2,1). +C + CALL DLARTG( A(1,1), A(2,1), CSL, SNL, R ) +C + END IF +C + CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) + CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSL, SNL ) +C + A(2,1) = ZERO + B(2,1) = ZERO +C +C Re-adjoint B. +C + R = B(1,1) + B(1,1) = B(2,2) + B(2,2) = R + B(1,2) = -B(1,2) +C + ELSE +C +C A pair of complex conjugate eigenvalues: +C first compute the SVD of the matrix adj(B). +C + R = B(1,1) + B(1,1) = B(2,2) + B(2,2) = R + B(1,2) = -B(1,2) + CALL DLASV2( B(1,1), B(1,2), B(2,2), R, T, SNL, CSL, + $ SNR, CSR ) +C +C Form (A,B) := Q(A,adj(B))Z' where Q is left rotation matrix +C and Z is right rotation matrix computed from DLASV2. +C + CALL DROT( 2, A(1,1), LDA, A(2,1), LDA, CSL, SNL ) + CALL DROT( 2, B(1,1), LDB, B(2,1), LDB, CSR, SNR ) + CALL DROT( 2, A(1,1), 1, A(1,2), 1, CSR, SNR ) + CALL DROT( 2, B(1,1), 1, B(1,2), 1, CSL, SNL ) +C + B(2,1) = ZERO + B(1,2) = ZERO + END IF +C + END IF +C +C Unscaling +C + R = B(1,1) + T = B(2,2) + A(1,1) = ANORM*A(1,1) + A(2,1) = ANORM*A(2,1) + A(1,2) = ANORM*A(1,2) + A(2,2) = ANORM*A(2,2) + B(1,1) = BNORM*B(1,1) + B(2,1) = BNORM*B(2,1) + B(1,2) = BNORM*B(1,2) + B(2,2) = BNORM*B(2,2) +C + IF( WI.EQ.ZERO ) THEN + ALPHAR(1) = A(1,1) + ALPHAR(2) = A(2,2) + ALPHAI(1) = ZERO + ALPHAI(2) = ZERO + BETA(1) = B(1,1) + BETA(2) = B(2,2) + ELSE + WR1 = ANORM*WR1 + WI = ANORM*WI + IF ( ABS( WR1 ).GT.ONE .OR. WI.GT.ONE ) THEN + WR1 = WR1*R + WI = WI*R + R = ONE + END IF + IF ( ABS( WR1 ).GT.ONE .OR. ABS( WI ).GT.ONE ) THEN + WR1 = WR1*T + WI = WI*T + T = ONE + END IF + ALPHAR(1) = ( WR1 / SCALE1 )*R*T + ALPHAI(1) = ABS( ( WI / SCALE1 )*R*T ) + ALPHAR(2) = ALPHAR(1) + ALPHAI(2) = -ALPHAI(1) + BETA(1) = BNORM + BETA(2) = BNORM + END IF + RETURN +C *** Last line of MB03YT *** + END diff --git a/mex/sources/libslicot/MB03ZA.f b/mex/sources/libslicot/MB03ZA.f new file mode 100644 index 000000000..814525200 --- /dev/null +++ b/mex/sources/libslicot/MB03ZA.f @@ -0,0 +1,1371 @@ + SUBROUTINE MB03ZA( COMPC, COMPU, COMPV, COMPW, WHICH, SELECT, N, + $ A, LDA, B, LDB, C, LDC, U1, LDU1, U2, LDU2, V1, + $ LDV1, V2, LDV2, W, LDW, WR, WI, M, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C 1. To compute, for a given matrix pair (A,B) in periodic Schur +C form, orthogonal matrices Ur and Vr so that +C +C T [ A11 A12 ] T [ B11 B12 ] +C Vr * A * Ur = [ ], Ur * B * Vr = [ ], (1) +C [ 0 A22 ] [ 0 B22 ] +C +C is in periodic Schur form, and the eigenvalues of A11*B11 +C form a selected cluster of eigenvalues. +C +C 2. To compute an orthogonal matrix W so that +C +C T [ 0 -A11 ] [ R11 R12 ] +C W * [ ] * W = [ ], (2) +C [ B11 0 ] [ 0 R22 ] +C +C where the eigenvalues of R11 and -R22 coincide and have +C positive real part. +C +C Optionally, the matrix C is overwritten by Ur'*C*Vr. +C +C All eigenvalues of A11*B11 must either be complex or real and +C negative. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPC CHARACTER*1 +C = 'U': update the matrix C; +C = 'N': do not update C. +C +C COMPU CHARACTER*1 +C = 'U': update the matrices U1 and U2; +C = 'N': do not update U1 and U2. +C See the description of U1 and U2. +C +C COMPV CHARACTER*1 +C = 'U': update the matrices V1 and V2; +C = 'N': do not update V1 and V2. +C See the description of V1 and V2. +C +C COMPW CHARACTER*1 +C Indicates whether or not the user wishes to accumulate +C the matrix W as follows: +C = 'N': the matrix W is not required; +C = 'I': W is initialized to the unit matrix and the +C orthogonal transformation matrix W is returned; +C = 'V': W must contain an orthogonal matrix Q on entry, +C and the product Q*W is returned. +C +C WHICH CHARACTER*1 +C = 'A': select all eigenvalues, this effectively means +C that Ur and Vr are identity matrices and A11 = A, +C B11 = B; +C = 'S': select a cluster of eigenvalues specified by +C SELECT. +C +C SELECT LOGICAL array, dimension (N) +C If WHICH = 'S', then SELECT specifies the eigenvalues of +C A*B in the selected cluster. To select a real eigenvalue +C w(j), SELECT(j) must be set to .TRUE.. To select a complex +C conjugate pair of eigenvalues w(j) and w(j+1), +C corresponding to a 2-by-2 diagonal block in A, both +C SELECT(j) and SELECT(j+1) must be set to .TRUE.; a complex +C conjugate pair of eigenvalues must be either both included +C in the cluster or both excluded. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi-triangular matrix A of the matrix +C pair (A,B) in periodic Schur form. +C On exit, the leading M-by-M part of this array contains +C the matrix R22 in (2). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular matrix B of the matrix pair +C (A,B) in periodic Schur form. +C On exit, the leading N-by-N part of this array is +C overwritten. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, if COMPC = 'U', the leading N-by-N part of this +C array must contain a general matrix C. +C On exit, if COMPC = 'U', the leading N-by-N part of this +C array contains the updated matrix Ur'*C*Vr. +C If COMPC = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= 1. +C LDC >= N, if COMPC = 'U' and WHICH = 'S'. +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, if COMPU = 'U' and WHICH = 'S', the leading +C N-by-N part of this array must contain U1, the (1,1) +C block of an orthogonal symplectic matrix +C U = [ U1, U2; -U2, U1 ]. +C On exit, if COMPU = 'U' and WHICH = 'S', the leading +C N-by-N part of this array contains U1*Ur. +C If COMPU = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDU1 INTEGER +C The leading dimension of the array U1. LDU1 >= 1. +C LDU1 >= N, if COMPU = 'U' and WHICH = 'S'. +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, if COMPU = 'U' and WHICH = 'S', the leading +C N-by-N part of this array must contain U2, the (1,2) +C block of an orthogonal symplectic matrix +C U = [ U1, U2; -U2, U1 ]. +C On exit, if COMPU = 'U' and WHICH = 'S', the leading +C N-by-N part of this array contains U2*Ur. +C If COMPU = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDU2 INTEGER +C The leading dimension of the array U2. LDU2 >= 1. +C LDU2 >= N, if COMPU = 'U' and WHICH = 'S'. +C +C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) +C On entry, if COMPV = 'U' and WHICH = 'S', the leading +C N-by-N part of this array must contain V1, the (1,1) +C block of an orthogonal symplectic matrix +C V = [ V1, V2; -V2, V1 ]. +C On exit, if COMPV = 'U' and WHICH = 'S', the leading +C N-by-N part of this array contains V1*Vr. +C If COMPV = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDV1 INTEGER +C The leading dimension of the array V1. LDV1 >= 1. +C LDV1 >= N, if COMPV = 'U' and WHICH = 'S'. +C +C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,N) +C On entry, if COMPV = 'U' and WHICH = 'S', the leading +C N-by-N part of this array must contain V2, the (1,2) +C block of an orthogonal symplectic matrix +C V = [ V1, V2; -V2, V1 ]. +C On exit, if COMPV = 'U' and WHICH = 'S', the leading +C N-by-N part of this array contains V2*Vr. +C If COMPV = 'N' or WHICH = 'A', this array is not +C referenced. +C +C LDV2 INTEGER +C The leading dimension of the array V2. LDV2 >= 1. +C LDV2 >= N, if COMPV = 'U' and WHICH = 'S'. +C +C W (input/output) DOUBLE PRECISION array, dimension (LDW,2*M) +C On entry, if COMPW = 'V', then the leading 2*M-by-2*M part +C of this array must contain a matrix W. +C If COMPW = 'I', then W need not be set on entry, W is set +C to the identity matrix. +C On exit, if COMPW = 'I' or 'V' the leading 2*M-by-2*M part +C of this array is post-multiplied by the transformation +C matrix that produced (2). +C If COMPW = 'N', this array is not referenced. +C +C LDW INTEGER +C The leading dimension of the array W. LDW >= 1. +C LDW >= 2*M, if COMPW = 'I' or COMPW = 'V'. +C +C WR (output) DOUBLE PRECISION array, dimension (M) +C WI (output) DOUBLE PRECISION array, dimension (M) +C The real and imaginary parts, respectively, of the +C eigenvalues of R22. The eigenvalues are stored in the same +C order as on the diagonal of R22, with +C WR(i) = R22(i,i) and, if R22(i:i+1,i:i+1) is a 2-by-2 +C diagonal block, WI(i) > 0 and WI(i+1) = -WI(i). +C In exact arithmetic, these eigenvalue are the positive +C square roots of the selected eigenvalues of the product +C A*B. However, if an eigenvalue is sufficiently +C ill-conditioned, then its value may differ significantly. +C +C M (output) INTEGER +C The number of selected eigenvalues. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = -28, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, 4*N, 8*M ). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: reordering of the product A*B in Step 1 failed +C because some eigenvalues are too close to separate; +C = 2: reordering of some submatrix in Step 2 failed +C because some eigenvalues are too close to separate; +C = 3: the QR algorithm failed to compute the Schur form +C of some submatrix in Step 2; +C = 4: the condition that all eigenvalues of A11*B11 must +C either be complex or real and negative is +C numerically violated. +C +C METHOD +C +C Step 1 is performed using a reordering technique analogous to the +C LAPACK routine DTGSEN for reordering matrix pencils [1,2]. Step 2 +C is an implementation of Algorithm 2 in [3]. It requires O(M*N*N) +C floating point operations. +C +C REFERENCES +C +C [1] Kagstrom, B. +C A direct method for reordering eigenvalues in the generalized +C real Schur form of a regular matrix pair (A,B), in M.S. Moonen +C et al (eds), Linear Algebra for Large Scale and Real-Time +C Applications, Kluwer Academic Publ., 1993, pp. 195-218. +C +C [2] Kagstrom, B. and Poromaa P.: +C Computing eigenspaces with specified eigenvalues of a regular +C matrix pair (A, B) and condition estimation: Theory, +C algorithms and software, Numer. Algorithms, 1996, vol. 12, +C pp. 369-407. +C +C [3] Benner, P., Mehrmann, V., and Xu, H. +C A new method for computing the stable invariant subspace of a +C real Hamiltonian matrix, J. Comput. Appl. Math., 86, +C pp. 17-43, 1997. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLABMX). +C +C KEYWORDS +C +C Hamiltonian matrix, invariant subspace. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER LDQZ + PARAMETER ( LDQZ = 4 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPC, COMPU, COMPV, COMPW, WHICH + INTEGER INFO, LDA, LDB, LDC, LDU1, LDU2, LDV1, LDV2, + $ LDW, LDWORK, M, N +C .. Array Arguments .. + LOGICAL SELECT(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ U1(LDU1,*), U2(LDU2,*), V1(LDV1,*), V2(LDV2,*), + $ W(LDW,*), WI(*), WR(*) +C .. Local Scalars .. + LOGICAL CMPALL, INITW, PAIR, SWAP, WANTC, WANTU, WANTV, + $ WANTW + INTEGER HERE, I, IERR, IFST, ILST, K, KS, L, LEN, MM, + $ NB, NBF, NBL, NBNEXT, POS, PW, PWC, PWCK, PWD, + $ PWDL, WRKMIN + DOUBLE PRECISION TEMP +C .. Local Arrays .. + LOGICAL LDUM(1), SELNEW(4) + DOUBLE PRECISION DW12(12), Q(LDQZ,LDQZ), T(LDQZ,LDQZ), WINEW(4), + $ WRNEW(4), Z(LDQZ,LDQZ) + INTEGER IDUM(1) +C .. External Functions .. + LOGICAL LFDUM, LSAME + EXTERNAL LFDUM, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DLACPY, DLASET, DSCAL, + $ DTRSEN, MB03WA, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Decode and check input parameters +C + WANTC = LSAME( COMPC, 'U' ) + WANTU = LSAME( COMPU, 'U' ) + WANTV = LSAME( COMPV, 'U' ) + INITW = LSAME( COMPW, 'I' ) + WANTW = INITW .OR. LSAME( COMPW, 'V' ) + CMPALL = LSAME( WHICH, 'A' ) + WRKMIN = MAX( 1, 4*N ) +C + INFO = 0 + IF ( .NOT.WANTC .AND. .NOT.LSAME( COMPC, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.WANTU .AND. .NOT.LSAME( COMPU, 'N' ) ) THEN + INFO = -2 + ELSE IF ( .NOT.WANTV .AND. .NOT.LSAME( COMPV, 'N' ) ) THEN + INFO = -3 + ELSE IF ( .NOT.WANTW .AND. .NOT.LSAME( COMPW, 'N' ) ) THEN + INFO = -4 + ELSE IF ( .NOT.CMPALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN + INFO = -5 + ELSE + IF ( CMPALL ) THEN + M = N + ELSE +C +C Set M to the dimension of the specified invariant subspace. +C + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF ( K.LT.N ) THEN + IF ( A(K+1,K).EQ.ZERO ) THEN + IF ( SELECT(K) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF ( SELECT(K) .OR. SELECT(K+1) ) + $ M = M + 2 + END IF + ELSE + IF ( SELECT(N) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + END IF +C +C Compute workspace requirements. +C + WRKMIN = MAX( WRKMIN, 8*M ) +C + IF ( N.LT.0 ) THEN + INFO = -7 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF ( LDC.LT.1 .OR. ( WANTC .AND. .NOT.CMPALL .AND. + $ LDC.LT.N ) ) THEN + INFO = -13 + ELSE IF ( LDU1.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. + $ LDU1.LT.N ) ) THEN + INFO = -15 + ELSE IF ( LDU2.LT.1 .OR. ( WANTU .AND. .NOT.CMPALL .AND. + $ LDU2.LT.N ) ) THEN + INFO = -17 + ELSE IF ( LDV1.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. + $ LDV1.LT.N ) ) THEN + INFO = -19 + ELSE IF ( LDV2.LT.1 .OR. ( WANTV .AND. .NOT.CMPALL .AND. + $ LDV2.LT.N ) ) THEN + INFO = -21 + ELSE IF ( LDW.LT.1 .OR. ( WANTW .AND. LDW.LT.2*M ) ) THEN + INFO = -23 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + INFO = -28 + DWORK(1) = DBLE( WRKMIN ) + END IF + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03ZA', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Jump immediately to Step 2, if all eigenvalues are requested. +C + IF ( CMPALL ) + $ GO TO 50 +C +C Step 1: Collect the selected blocks at the top-left corner of A*B. +C + KS = 0 + PAIR = .FALSE. + DO 40 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + SWAP = SELECT(K) + IF ( K.LT.N ) THEN + IF ( A(K+1,K).NE.ZERO ) THEN + PAIR = .TRUE. + SWAP = SWAP .OR. SELECT(K+1) + END IF + END IF +C + IF ( PAIR ) THEN + NBF = 2 + ELSE + NBF = 1 + END IF +C + IF ( SWAP ) THEN + KS = KS + 1 + IFST = K +C +C Swap the K-th block to position KS. +C + ILST = KS + NBL = 1 + IF ( ILST.GT.1 ) THEN + IF ( A(ILST,ILST-1).NE.ZERO ) THEN + ILST = ILST - 1 + NBL = 2 + END IF + END IF +C + IF ( ILST.EQ.IFST ) + $ GO TO 30 +C + HERE = IFST + 20 CONTINUE +C +C Swap block with next one above. +C + IF ( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN +C +C Current block either 1-by-1 or 2-by-2. +C + NBNEXT = 1 + IF ( HERE.GE.3 ) THEN + IF ( A(HERE-1,HERE-2).NE.ZERO ) + $ NBNEXT = 2 + END IF + POS = HERE - NBNEXT + NB = NBNEXT + NBF + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., NBNEXT, NBF, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, + $ IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, + $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), + $ LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, + $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), + $ LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), + $ LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, + $ ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), + $ LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), + $ LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), + $ LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), + $ LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), + $ LDV2 ) + END IF +C + HERE = HERE - NBNEXT +C +C Test if 2-by-2 block breaks into two 1-by-1 blocks. +C + IF ( NBF.EQ.2 ) THEN + IF ( A(HERE+1,HERE).EQ.ZERO ) + $ NBF = 3 + END IF +C + ELSE +C +C Current block consists of two 1 by 1 blocks each of +C which must be swapped individually. +C + NBNEXT = 1 + IF ( HERE.GE.3 ) THEN + IF ( A(HERE-1,HERE-2).NE.ZERO ) + $ NBNEXT = 2 + END IF + POS = HERE - NBNEXT + NB = NBNEXT + 1 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, LDQZ, + $ IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, + $ NB, NB, ONE, A(1,POS), LDA, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, A(1,POS), + $ LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', POS-1, + $ NB, NB, ONE, B(1,POS), LDB, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, B(1,POS), + $ LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), + $ LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, + $ ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), + $ LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U1(1,POS), LDU1, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), + $ LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U2(1,POS), LDU2, Z, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), + $ LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V1(1,POS), LDV1, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), + $ LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V2(1,POS), LDV2, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), + $ LDV2 ) + END IF +C + IF ( NBNEXT.EQ.1 ) THEN +C +C Swap two 1-by-1 blocks. +C + POS = HERE + NB = NBNEXT + 1 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., NBNEXT, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, + $ LDQZ, IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, A(1,POS), LDA, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ A(1,POS), LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, B(1,POS), LDB, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ B(1,POS), LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, NB, + $ B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, C(1,POS), LDC, Q, LDQZ, + $ ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, C(1,POS), + $ LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), LDC, + $ ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, C(POS,1), + $ LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U1(1,POS), LDU1, Z, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U1(1,POS), + $ LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, U2(1,POS), LDU2, Z, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, U2(1,POS), + $ LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V1(1,POS), LDV1, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V1(1,POS), + $ LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, + $ NB, NB, ONE, V2(1,POS), LDV2, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, V2(1,POS), + $ LDV2 ) + END IF +C + HERE = HERE - 1 + ELSE +C +C Recompute NBNEXT in case 2-by-2 split. +C + IF ( A(HERE,HERE-1).EQ.ZERO ) + $ NBNEXT = 1 +C + IF ( NBNEXT.EQ.2 ) THEN +C +C 2-by-2 block did not split. +C + POS = HERE - 1 + NB = 3 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, + $ LDQZ, IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, A(1,POS), + $ LDA, Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ A(1,POS), LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, B(1,POS), + $ LDB, Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ B(1,POS), LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, C(1,POS), LDC, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ C(1,POS), LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), + $ LDC, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, + $ C(POS,1), LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U1(1,POS), LDU1, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U1(1,POS), LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U2(1,POS), LDU2, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U2(1,POS), LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V1(1,POS), LDV1, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V1(1,POS), LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V2(1,POS), LDV2, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V2(1,POS), LDV2 ) + END IF +C + HERE = HERE - 2 + ELSE +C +C 2-by-2 block did split. +C + POS = HERE + NB = 2 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, + $ LDQZ, IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, A(1,POS), + $ LDA, Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ A(1,POS), LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, B(1,POS), + $ LDB, Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ B(1,POS), LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, C(1,POS), LDC, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ C(1,POS), LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), + $ LDC, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, + $ C(POS,1), LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U1(1,POS), LDU1, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U1(1,POS), LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U2(1,POS), LDU2, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U2(1,POS), LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V1(1,POS), LDV1, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V1(1,POS), LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V2(1,POS), LDV2, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V2(1,POS), LDV2 ) + END IF +C + POS = HERE - 1 + NB = 2 + CALL DLASET( 'All', NB, NB, ZERO, ONE, Q, LDQZ ) + CALL DLASET( 'All', NB, NB, ZERO, ONE, Z, LDQZ ) +C + CALL MB03WA( .TRUE., .TRUE., 2, 1, A(POS,POS), + $ LDA, B(POS,POS), LDB, Q, LDQZ, Z, + $ LDQZ, IERR ) +C + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 1 + RETURN + END IF +C +C Update rest of A. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, A(1,POS), + $ LDA, Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ A(1,POS), LDA ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Q, LDQZ, + $ A(POS,POS+NB), LDA, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, A(POS,POS+NB), LDA ) + END IF +C +C Update rest of B. +C + IF ( POS.GT.1 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ POS-1, NB, NB, ONE, B(1,POS), + $ LDB, Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', POS-1, NB, DWORK, N, + $ B(1,POS), LDB ) + END IF + IF ( POS+NB.LE.N ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N-POS-NB+1, NB, ONE, Z, LDQZ, + $ B(POS,POS+NB), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'All', NB, N-POS-NB+1, DWORK, + $ NB, B(POS,POS+NB), LDB ) + END IF +C +C Update C. +C + IF ( WANTC ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, C(1,POS), LDC, Q, + $ LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ C(1,POS), LDC ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, + $ N, NB, ONE, Z, LDQZ, C(POS,1), + $ LDC, ZERO, DWORK, NB ) + CALL DLACPY( 'All', NB, N, DWORK, NB, + $ C(POS,1), LDC ) + END IF +C +C Update U. +C + IF ( WANTU ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U1(1,POS), LDU1, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U1(1,POS), LDU1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, U2(1,POS), LDU2, + $ Z, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ U2(1,POS), LDU2 ) + END IF +C +C Update V. +C + IF ( WANTV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V1(1,POS), LDV1, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V1(1,POS), LDV1 ) + CALL DGEMM( 'No Transpose', 'No Transpose', + $ N, NB, NB, ONE, V2(1,POS), LDV2, + $ Q, LDQZ, ZERO, DWORK, N ) + CALL DLACPY( 'All', N, NB, DWORK, N, + $ V2(1,POS), LDV2 ) + END IF +C + HERE = HERE - 2 + END IF + END IF + END IF +C + IF ( HERE.GT.ILST ) + $ GO TO 20 +C + 30 CONTINUE + IF ( PAIR ) + $ KS = KS + 1 + END IF + END IF + 40 CONTINUE +C + 50 CONTINUE +C +C Step 2: Compute an ordered Schur decomposition of +C [ 0, -A11; B11, 0 ]. +C + IF ( INITW ) + $ CALL DLASET( 'All', 2*M, 2*M, ZERO, ONE, W, LDW ) + PWC = 1 + PWD = PWC + 2*M + PW = PWD + 2*M + PAIR = .FALSE. + NB = 1 +C + DO 80 K = 1, M + IF ( PAIR ) THEN + PAIR = .FALSE. + NB = 1 + ELSE + IF ( K.LT.N ) THEN + IF ( A(K+1,K).NE.ZERO ) THEN + PAIR = .TRUE. + NB = 2 + END IF + END IF + PWCK = PWC + 2*( K - 1 ) + PWDL = PWD + 2*( K - 1 ) + CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, DWORK(PWCK), 2 ) + CALL DLACPY( 'All', NB, M-K+1, A(K,K), LDA, DWORK(PWDL), 2 ) + CALL DLASET( 'All', NB, M-K+1, ZERO, ZERO, A(K,K), LDA ) +C + L = K +C +C WHILE L >= 1 DO +C + 60 CONTINUE +C + IF ( K.EQ.L ) THEN +C +C Annihilate B(k,k). +C + NBL = NB + CALL DLASET( 'All', NB+NBL, NB+NBL, ZERO, ZERO, T, + $ LDQZ ) + CALL DLACPY( 'Upper', NBL, NBL, B(L,L), LDB, + $ T(NB+1,1), LDQZ ) + IF ( NB.EQ.1 ) THEN + DWORK(PWDL) = -DWORK(PWDL) + ELSE + CALL DSCAL( 2*NB, -ONE, DWORK(PWDL), 1 ) + END IF + CALL DLACPY( 'All', NB, NB, DWORK(PWDL), 2, T(1,NB+1), + $ LDQZ ) + ELSE +C +C Annihilate B(l,k). +C + CALL DLASET( 'All', NBL+NB, NBL+NB, ZERO, ZERO, T, + $ LDQZ ) + CALL DLACPY( 'All', NBL, NBL, A(L,L), LDA, T, LDQZ ) + CALL DLACPY( 'All', NBL, NB, B(L,K), LDB, T(1,NBL+1), + $ LDQZ ) + CALL DLACPY( 'All', NB, NB, DWORK(PWCK), 2, + $ T(NBL+1,NBL+1), LDQZ ) + PWDL = PWD + 2*( L - 1 ) + END IF +C + CALL DGEES( 'V', 'Not Sorted', LFDUM, NB+NBL, T, LDQZ, + $ MM, WRNEW, WINEW, Q, LDQZ, DW12, 12, LDUM, + $ IERR ) + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 3 + RETURN + END IF +C +C Reorder Schur form. +C + MM = 0 + DO 70 I = 1, NB+NBL + IF ( WRNEW(I).GT.0 ) THEN + MM = MM + 1 + SELNEW(I) = .TRUE. + ELSE + SELNEW(I) = .FALSE. + END IF + 70 CONTINUE + IF ( MM.LT.NB ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 4 + RETURN + END IF + CALL DTRSEN( 'None', 'V', SELNEW, NB+NBL, T, LDQZ, Q, + $ LDQZ, WRNEW, WINEW, MM, TEMP, TEMP, DW12, + $ 4, IDUM, 1, IERR ) + IF ( IERR.NE.0 ) THEN + DWORK(1) = DBLE( WRKMIN ) + INFO = 2 + RETURN + END IF +C +C Permute Q if necessary. +C + IF ( K.NE.L ) THEN + CALL DLACPY( 'All', NBL, NB+NBL, Q, LDQZ, Z(NB+1,1), + $ LDQZ ) + CALL DLACPY( 'All', NB, NB+NBL, Q(NBL+1,1), LDQZ, + $ Z, LDQZ ) + CALL DLACPY( 'All', NB+NBL, NB+NBL, Z, LDQZ, Q, LDQZ ) + END IF +C +C Update "diagonal" blocks. +C + CALL DLACPY( 'All', NB, NB, T, LDQZ, DWORK(PWCK), 2 ) + CALL DLACPY( 'All', NB, NBL, T(1,NB+1), LDQZ, + $ DWORK(PWDL), 2 ) + IF ( NB.EQ.1 ) THEN + CALL DSCAL( NBL, -ONE, DWORK(PWDL), 2 ) + ELSE + CALL DSCAL( 2*NBL, -ONE, DWORK(PWDL), 1 ) + END IF + CALL DLACPY( 'All', NBL, NBL, T(NB+1,NB+1), LDQZ, + $ A(L,L), LDA ) +C +C Update block columns of A and B. +C + LEN = L - 1 + IF ( LEN.GT.0 ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NB, ONE, B(1,K), LDB, Q, LDQZ, ZERO, + $ DWORK(PW), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NB, ONE, B(1,K), LDB, Q(1,NB+1), LDQZ, + $ ZERO, DWORK(PW+2*M), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NBL, ONE, A(1,L), LDA, Q(NB+1,1), LDQZ, + $ ONE, DWORK(PW), M ) + CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, B(1,K), + $ LDB ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NBL, ONE, A(1,L), LDA, Q(NB+1,NB+1), + $ LDQZ, ONE, DWORK(PW+2*M), M ) + CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, + $ A(1,L), LDA ) + END IF +C +C Update block column of A. +C + LEN = M - L - NBL + 1 + IF ( LEN.GT.0 ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, + $ ONE, Q, LDQZ, DWORK(PWDL+2*NBL), 2, ZERO, + $ DWORK(PW), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, + $ -ONE, Q(1,NB+1), LDQZ, DWORK(PWDL+2*NBL), + $ 2, ZERO, DWORK(PW+2*M), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, + $ -ONE, Q(NB+1,1), LDQZ, A(L,L+NBL), LDA, + $ ONE, DWORK(PW), 2 ) + CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, + $ DWORK(PWDL+2*NBL), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, + $ NBL, ONE, Q(NB+1,NB+1), LDQZ, A(L,L+NBL), + $ LDA, ONE, DWORK(PW+2*M), 2 ) + CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, + $ A(L,L+NBL), LDA ) + END IF +C +C Update block row of B. +C + LEN = M - K - NB + 1 + IF ( LEN.GT.0 ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NB, + $ ONE, Q, LDQZ, DWORK(PWCK+2*NB), 2, ZERO, + $ DWORK(PW), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, NB, + $ ONE, Q(1,NB+1), LDQZ, DWORK(PWCK+2*NB), 2, + $ ZERO, DWORK(PW+2*M), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NB, LEN, NBL, + $ ONE, Q(NB+1,1), LDQZ, B(L,K+NB), LDB, ONE, + $ DWORK(PW), 2 ) + CALL DLACPY( 'All', NB, LEN, DWORK(PW), 2, + $ DWORK(PWCK+2*NB), 2 ) + CALL DGEMM( 'Transpose', 'No Transpose', NBL, LEN, + $ NBL, ONE, Q(NB+1,NB+1), LDQZ, B(L,K+NB), + $ LDB, ONE, DWORK(PW+2*M), 2 ) + CALL DLACPY( 'All', NBL, LEN, DWORK(PW+2*M), 2, + $ B(L,K+NB), LDB ) + END IF +C +C Update W. +C + IF ( WANTW ) THEN + IF ( INITW ) THEN + POS = L + LEN = K + NB - L + ELSE + POS = 1 + LEN = M + END IF + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NB, ONE, W(POS,K), LDW, Q, LDQZ, ZERO, + $ DWORK(PW), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NB, ONE, W(POS,K), LDW, Q(1,NB+1), LDQZ, + $ ZERO, DWORK(PW+2*M), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,1), + $ LDQZ, ONE, DWORK(PW), M ) + CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(POS,K), + $ LDW ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NBL, ONE, W(POS,M+L), LDW, Q(NB+1,NB+1), + $ LDQZ, ONE, DWORK(PW+2*M), M ) + CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, + $ W(POS,M+L), LDW ) +C + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NB, ONE, W(M+POS,K), LDW, Q, LDQZ, ZERO, + $ DWORK(PW), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NB, ONE, W(M+POS,K), LDW, Q(1,NB+1), LDQZ, + $ ZERO, DWORK(PW+2*M), M ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NB, + $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,1), + $ LDQZ, ONE, DWORK(PW), M ) + CALL DLACPY( 'All', LEN, NB, DWORK(PW), M, W(M+POS,K), + $ LDW ) + CALL DGEMM( 'No Transpose', 'No Transpose', LEN, NBL, + $ NBL, ONE, W(M+POS,M+L), LDW, Q(NB+1,NB+1), + $ LDQZ, ONE, DWORK(PW+2*M), M ) + CALL DLACPY( 'All', LEN, NBL, DWORK(PW+2*M), M, + $ W(M+POS,M+L), LDW ) + END IF +C + L = L - 1 + NBL = 1 + IF ( L.GT.1 ) THEN + IF ( A(L,L-1).NE.ZERO ) THEN + NBL = 2 + L = L - 1 + END IF + END IF +C +C END WHILE L >= 1 DO +C + IF ( L.GE.1 ) + $ GO TO 60 +C +C Copy recomputed eigenvalues. +C + CALL DCOPY( NB, WRNEW, 1, WR(K), 1 ) + CALL DCOPY( NB, WINEW, 1, WI(K), 1 ) + END IF + 80 CONTINUE + DWORK(1) = DBLE( WRKMIN ) + RETURN +C *** Last line of MB03ZA *** + END +C + LOGICAL FUNCTION LFDUM( X, Y ) +C +C Void logical function for DGEES. +C + DOUBLE PRECISION X, Y + LFDUM = .FALSE. + RETURN +C *** Last line of LFDUM *** + END diff --git a/mex/sources/libslicot/MB03ZD.f b/mex/sources/libslicot/MB03ZD.f new file mode 100644 index 000000000..74e945525 --- /dev/null +++ b/mex/sources/libslicot/MB03ZD.f @@ -0,0 +1,908 @@ + SUBROUTINE MB03ZD( WHICH, METH, STAB, BALANC, ORTBAL, SELECT, N, + $ MM, ILO, SCALE, S, LDS, T, LDT, G, LDG, U1, + $ LDU1, U2, LDU2, V1, LDV1, V2, LDV2, M, WR, WI, + $ US, LDUS, UU, LDUU, LWORK, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the stable and unstable invariant subspaces for a +C Hamiltonian matrix with no eigenvalues on the imaginary axis, +C using the output of the SLICOT Library routine MB03XD. +C +C ARGUMENTS +C +C Mode Parameters +C +C WHICH CHARACTER*1 +C Specifies the cluster of eigenvalues for which the +C invariant subspaces are computed: +C = 'A': select all n eigenvalues; +C = 'S': select a cluster of eigenvalues specified by +C SELECT. +C +C METH CHARACTER*1 +C If WHICH = 'A' this parameter specifies the method to be +C used for computing bases of the invariant subspaces: +C = 'S': compute the n-dimensional basis from a set of +C n vectors; +C = 'L': compute the n-dimensional basis from a set of +C 2*n vectors. +C When in doubt, use METH = 'S'. In some cases, METH = 'L' +C may result in more accurately computed invariant +C subspaces, see [1]. +C +C STAB CHARACTER*1 +C Specifies the type of invariant subspaces to be computed: +C = 'S': compute the stable invariant subspace, i.e., the +C invariant subspace belonging to those selected +C eigenvalues that have negative real part; +C = 'U': compute the unstable invariant subspace, i.e., +C the invariant subspace belonging to those +C selected eigenvalues that have positive real +C part; +C = 'B': compute both the stable and unstable invariant +C subspaces. +C +C BALANC CHARACTER*1 +C Specifies the type of inverse balancing transformation +C required: +C = 'N': do nothing; +C = 'P': do inverse transformation for permutation only; +C = 'S': do inverse transformation for scaling only; +C = 'B': do inverse transformations for both permutation +C and scaling. +C BALANC must be the same as the argument BALANC supplied to +C MB03XD. Note that if the data is further post-processed, +C e.g., for solving an algebraic Riccati equation, it is +C recommended to delay inverse balancing (in particular the +C scaling part) and apply it to the final result only, +C see [2]. +C +C ORTBAL CHARACTER*1 +C If BALANC <> 'N', this option specifies how inverse +C balancing is applied to the computed invariant subspaces: +C = 'B': apply inverse balancing before orthogonal bases +C for the invariant subspaces are computed; +C = 'A': apply inverse balancing after orthogonal bases +C for the invariant subspaces have been computed; +C this may yield non-orthogonal bases if +C BALANC = 'S' or BALANC = 'B'. +C +C SELECT (input) LOGICAL array, dimension (N) +C If WHICH = 'S', SELECT specifies the eigenvalues +C corresponding to the positive and negative square +C roots of the eigenvalues of S*T in the selected cluster. +C To select a real eigenvalue w(j), SELECT(j) must be set +C to .TRUE.. To select a complex conjugate pair of +C eigenvalues w(j) and w(j+1), corresponding to a 2-by-2 +C diagonal block, both SELECT(j) and SELECT(j+1) must be set +C to .TRUE.; a complex conjugate pair of eigenvalues must be +C either both included in the cluster or both excluded. +C This array is not referenced if WHICH = 'A'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices S, T and G. N >= 0. +C +C MM (input) INTEGER +C The number of columns in the arrays US and/or UU. +C If WHICH = 'A' and METH = 'S', MM >= N; +C if WHICH = 'A' and METH = 'L', MM >= 2*N; +C if WHICH = 'S', MM >= M. +C The minimal values above for MM give the numbers of +C vectors to be used for computing a basis for the +C invariant subspace(s). +C +C ILO (input) INTEGER +C If BALANC <> 'N', then ILO is the integer returned by +C MB03XD. 1 <= ILO <= N+1. +C +C SCALE (input) DOUBLE PRECISION array, dimension (N) +C If BALANC <> 'N', the leading N elements of this array +C must contain details of the permutation and scaling +C factors, as returned by MB03XD. +C This array is not referenced if BALANC = 'N'. +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix S in real Schur form. +C On exit, the leading N-by-N part of this array is +C overwritten. +C +C LDS INTEGER +C The leading dimension of the array S. LDS >= max(1,N). +C +C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular matrix T. +C On exit, the leading N-by-N part of this array is +C overwritten. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, if METH = 'L', the leading N-by-N part of this +C array must contain a general matrix G. +C On exit, if METH = 'L', the leading N-by-N part of this +C array is overwritten. +C This array is not referenced if METH = 'S'. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= 1. +C LDG >= max(1,N) if METH = 'L'. +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, the leading N-by-N part of this array must +C contain the (1,1) block of an orthogonal symplectic +C matrix U. +C On exit, this array is overwritten. +C +C LDU1 INTEGER +C The leading dimension of the array U1. LDU1 >= MAX(1,N). +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, the leading N-by-N part of this array must +C contain the (2,1) block of an orthogonal symplectic +C matrix U. +C On exit, this array is overwritten. +C +C LDU2 INTEGER +C The leading dimension of the array U2. LDU2 >= MAX(1,N). +C +C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) +C On entry, the leading N-by-N part of this array must +C contain the (1,1) block of an orthogonal symplectic +C matrix V. +C On exit, this array is overwritten. +C +C LDV1 INTEGER +C The leading dimension of the array V1. LDV1 >= MAX(1,N). +C +C V2 (input/output) DOUBLE PRECISION array, dimension (LDV1,N) +C On entry, the leading N-by-N part of this array must +C contain the (2,1) block of an orthogonal symplectic +C matrix V. +C On exit, this array is overwritten. +C +C LDV2 INTEGER +C The leading dimension of the array V2. LDV2 >= MAX(1,N). +C +C M (output) INTEGER +C The number of selected eigenvalues. +C +C WR (output) DOUBLE PRECISION array, dimension (M) +C WI (output) DOUBLE PRECISION array, dimension (M) +C On exit, the leading M elements of WR and WI contain the +C real and imaginary parts, respectively, of the selected +C eigenvalues that have nonpositive real part. Complex +C conjugate pairs of eigenvalues with real part not equal +C to zero will appear consecutively with the eigenvalue +C having the positive imaginary part first. Note that, due +C to roundoff errors, these numbers may differ from the +C eigenvalues computed by MB03XD. +C +C US (output) DOUBLE PRECISION array, dimension (LDUS,MM) +C On exit, if STAB = 'S' or STAB = 'B', the leading 2*N-by-M +C part of this array contains a basis for the stable +C invariant subspace belonging to the selected eigenvalues. +C This basis is orthogonal unless ORTBAL = 'A'. +C +C LDUS INTEGER +C The leading dimension of the array US. LDUS >= 1. +C If STAB = 'S' or STAB = 'B', LDUS >= 2*N. +C +C UU (output) DOUBLE PRECISION array, dimension (LDUU,MM) +C On exit, if STAB = 'U' or STAB = 'B', the leading 2*N-by-M +C part of this array contains a basis for the unstable +C invariant subspace belonging to the selected eigenvalues. +C This basis is orthogonal unless ORTBAL = 'A'. +C +C LDUU INTEGER +C The leading dimension of the array UU. LDUU >= 1. +C If STAB = 'U' or STAB = 'B', LDUU >= 2*N. +C +C Workspace +C +C LWORK LOGICAL array, dimension (2*N) +C This array is only referenced if WHICH = 'A' and +C METH = 'L'. +C +C IWORK INTEGER array, dimension (2*N), +C This array is only referenced if WHICH = 'A' and +C METH = 'L'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -35, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If WHICH = 'S' or METH = 'S': +C LDWORK >= MAX( 1, 4*M*M + MAX( 8*M, 4*N ) ). +C If WHICH = 'A' and METH = 'L' and +C ( STAB = 'U' or STAB = 'S' ): +C LDWORK >= MAX( 1, 2*N*N + 2*N, 8*N ). +C If WHICH = 'A' and METH = 'L' and STAB = 'B': +C LDWORK >= 8*N + 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: some of the selected eigenvalues are on or too close +C to the imaginary axis; +C = 2: reordering of the product S*T in routine MB03ZA +C failed because some eigenvalues are too close to +C separate; +C = 3: the QR algorithm failed to compute some Schur form +C in MB03ZA; +C = 4: reordering of the Hamiltonian Schur form in routine +C MB03TD failed because some eigenvalues are too close +C to separate. +C +C METHOD +C +C This is an implementation of Algorithm 1 in [1]. +C +C NUMERICAL ASPECTS +C +C The method is strongly backward stable for an embedded +C (skew-)Hamiltonian matrix, see [1]. Although good results have +C been reported if the eigenvalues are not too close to the +C imaginary axis, the method is not backward stable for the original +C Hamiltonian matrix itself. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A new method for computing the stable invariant subspace of a +C real Hamiltonian matrix, J. Comput. Appl. Math., 86, +C pp. 17-43, 1997. +C +C [2] Benner, P. +C Symplectic balancing of Hamiltonian matrices. +C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHASUB). +C +C KEYWORDS +C +C Hamiltonian matrix, invariant subspace. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC, METH, ORTBAL, STAB, WHICH + INTEGER ILO, INFO, LDG, LDS, LDT, LDU1, LDU2, LDUS, + $ LDUU, LDV1, LDV2, LDWORK, M, MM, N +C .. Array Arguments .. + LOGICAL LWORK(*), SELECT(*) + INTEGER IWORK(*) + DOUBLE PRECISION DWORK(*), G(LDG,*), S(LDS,*), SCALE(*), + $ T(LDT,*), U1(LDU1,*), U2(LDU2,*), US(LDUS,*), + $ UU(LDUU,*), V1(LDV1,*), V2(LDV2,*), WI(*), + $ WR(*) +C .. Local Scalars .. + LOGICAL LALL, LBAL, LBEF, LEXT, LUS, LUU, PAIR + INTEGER I, IERR, J, K, PDW, PW, WRKMIN, WRKOPT + DOUBLE PRECISION TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DGEMM, DGEQP3, DGEQRF, DLACPY, DLASCL, + $ DLASET, DORGQR, DSCAL, MB01UX, MB03TD, MB03ZA, + $ MB04DI, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode and check input parameters. +C + LALL = LSAME( WHICH, 'A' ) + IF ( LALL ) THEN + LEXT = LSAME( METH, 'L' ) + ELSE + LEXT = .FALSE. + END IF + LUS = LSAME( STAB, 'S' ) .OR. LSAME( STAB, 'B' ) + LUU = LSAME( STAB, 'U' ) .OR. LSAME( STAB, 'B' ) + LBAL = LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'S' ) .OR. + $ LSAME( BALANC, 'B' ) + LBEF = .FALSE. + IF ( LBAL ) + $ LBEF = LSAME( ORTBAL, 'B' ) +C + WRKMIN = 1 + WRKOPT = WRKMIN +C + INFO = 0 +C + IF ( .NOT.LALL .AND. .NOT.LSAME( WHICH, 'S' ) ) THEN + INFO = -1 + ELSE IF ( LALL .AND. ( .NOT.LEXT .AND. + $ .NOT.LSAME( METH, 'S' ) ) ) THEN + INFO = -2 + ELSE IF ( .NOT.LUS .AND. .NOT.LUU ) THEN + INFO = -3 + ELSE IF ( .NOT.LBAL .AND. .NOT.LSAME( BALANC, 'N' ) ) THEN + INFO = -4 + ELSE IF ( LBAL .AND. ( .NOT.LBEF .AND. + $ .NOT.LSAME( ORTBAL, 'A' ) ) ) THEN + INFO = -5 + ELSE + IF ( LALL ) THEN + M = N + ELSE +C +C Set M to the dimension of the specified invariant subspace. +C + M = 0 + PAIR = .FALSE. + DO 10 K = 1, N + IF ( PAIR ) THEN + PAIR = .FALSE. + ELSE + IF ( K.LT.N ) THEN + IF ( S(K+1,K).EQ.ZERO ) THEN + IF ( SELECT(K) ) + $ M = M + 1 + ELSE + PAIR = .TRUE. + IF ( SELECT(K) .OR. SELECT(K+1) ) + $ M = M + 2 + END IF + ELSE + IF ( SELECT(N) ) + $ M = M + 1 + END IF + END IF + 10 CONTINUE + END IF +C +C Compute workspace requirements. +C + IF ( .NOT.LEXT ) THEN + WRKOPT = MAX( WRKOPT, 4*M*M + MAX( 8*M, 4*N ) ) + ELSE + IF ( LUS.AND.LUU ) THEN + WRKOPT = MAX( WRKOPT, 8*N + 1 ) + ELSE + WRKOPT = MAX( WRKOPT, 2*N*N + 2*N, 8*N ) + END IF + END IF +C + IF ( N.LT.0 ) THEN + INFO = -7 + ELSE IF ( MM.LT.M .OR. ( LEXT .AND. MM.LT.2*N ) ) THEN + INFO = -8 + ELSE IF ( LBAL .AND. ( ILO.LT.1 .OR. ILO.GT.N+1 ) ) THEN + INFO = -9 + ELSE IF ( LDS.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDT.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF ( LDG.LT.1 .OR. ( LEXT .AND. LDG.LT.N ) ) THEN + INFO = -16 + ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF ( LDUS.LT.1 .OR. ( LUS .AND. LDUS.LT.2*N ) ) THEN + INFO = -29 + ELSE IF ( LDUU.LT.1 .OR. ( LUU .AND. LDUU.LT.2*N ) ) THEN + INFO = -31 + ELSE IF ( LDWORK.LT.WRKMIN ) THEN + INFO = -35 + DWORK(1) = DBLE( WRKMIN ) + END IF + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB03ZD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF + WRKOPT = WRKMIN +C + IF ( .NOT.LEXT ) THEN +C +C Workspace requirements: 4*M*M + MAX( 8*M, 4*N ). +C + PW = 1 + PDW = PW + 4*M*M + CALL MB03ZA( 'No Update', 'Update', 'Update', 'Init', WHICH, + $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, U2, + $ LDU2, V1, LDV1, V2, LDV2, DWORK(PW), 2*M, WR, WI, + $ M, DWORK(PDW), LDWORK-PDW+1, IERR ) + IF ( IERR.NE.0 ) + $ GO TO 250 +C + PDW = PW + 2*M*M + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, + $ DWORK(PW), 2*M, V1, LDV1, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C + IF ( LUS ) + $ CALL DLACPY( 'All', N, M, V1, LDV1, US, LDUS ) + IF ( LUU ) + $ CALL DLACPY( 'All', N, M, V1, LDV1, UU, LDUU ) +C + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, + $ DWORK(PW+M), 2*M, U1, LDU1, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) +C + IF ( LUS ) THEN + DO 20 J = 1, M + CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,J), 1 ) + 20 CONTINUE + END IF + IF ( LUU ) THEN + DO 30 J = 1, M + CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,J), 1 ) + 30 CONTINUE + END IF +C + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, -ONE, + $ DWORK(PW), 2*M, V2, LDV2, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) +C + IF ( LUS ) + $ CALL DLACPY( 'All', N, M, V2, LDV2, US(N+1,1), LDUS ) + IF ( LUU ) + $ CALL DLACPY( 'All', N, M, V2, LDV2, UU(N+1,1), LDUU ) +C + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, M, ONE, + $ DWORK(PW+M), 2*M, U2, LDU2, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) +C + IF ( LUS ) THEN + DO 40 J = 1, M + CALL DAXPY( N, ONE, U2(1,J), 1, US(N+1,J), 1 ) + 40 CONTINUE + END IF + IF ( LUU ) THEN + DO 50 J = 1, M + CALL DAXPY( N, -ONE, U2(1,J), 1, UU(N+1,J), 1 ) + 50 CONTINUE + END IF +C +C Orthonormalize obtained bases and apply inverse balancing +C transformation. +C + IF ( LBAL .AND. LBEF ) THEN + IF ( LUS ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, + $ LDUS, US(N+1,1), LDUS, IERR ) + IF ( LUU ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, + $ LDUU, UU(N+1,1), LDUU, IERR ) + END IF +C + IF ( LUS ) THEN + CALL DGEQRF( 2*N, M, US, LDUS, DWORK(1), DWORK(M+1), + $ LDWORK-M, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) + CALL DORGQR( 2*N, M, M, US, LDUS, DWORK(1), DWORK(M+1), + $ LDWORK-M, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) + END IF + IF ( LUU ) THEN + CALL DGEQRF( 2*N, M, UU, LDUU, DWORK(1), DWORK(M+1), + $ LDWORK-M, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) + CALL DORGQR( 2*N, M, M, UU, LDUU, DWORK(1), DWORK(M+1), + $ LDWORK-M, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(M+1) ) + M ) + END IF +C + IF ( LBAL .AND. .NOT.LBEF ) THEN + IF ( LUS ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, US, + $ LDUS, US(N+1,1), LDUS, IERR ) + IF ( LUU ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, M, UU, + $ LDUU, UU(N+1,1), LDUU, IERR ) + END IF +C + ELSE +C + DO 60 I = 1, 2*N + LWORK(I) = .TRUE. + 60 CONTINUE +C + IF ( LUS .AND.( .NOT.LUU ) ) THEN +C +C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) +C + CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, + $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, + $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, + $ WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) + $ GO TO 250 +C + CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C + DO 70 J = 1, N + CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) + 70 CONTINUE + PDW = 2*N*N+1 +C +C DW <- -[V1;V2]*W11 +C + CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) + CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, + $ US, LDUS, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C +C DW2 <- DW2 - U2*W21 +C + CALL DLACPY( 'All', N, N, U2, LDU2, US, LDUS ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, + $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + DO 80 J = 1, N + CALL DAXPY( N, ONE, US(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) + 80 CONTINUE +C +C US11 <- -U1*W21 - DW1 +C + CALL DLACPY( 'All', N, N, U1, LDU1, US, LDUS ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, + $ US(N+1,1), LDUS, US, LDUS, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + DO 90 J = 1, N + CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, US(1,J), 1 ) + 90 CONTINUE +C +C US21 <- DW2 +C + CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, US(N+1,1), LDUS ) +C + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, + $ IERR ) + CALL DLACPY( 'All', N, N, V1, LDV1, US(1,N+1), LDUS ) + CALL DLACPY( 'All', N, N, V2, LDV2, US(N+1,N+1), LDUS ) + DO 100 J = 1, N + CALL DAXPY( N, -ONE, U1(1,J), 1, US(1,N+J), 1 ) + 100 CONTINUE + DO 110 J = 1, N + CALL DAXPY( N, -ONE, U2(1,J), 1, US(N+1,N+J), 1 ) + 110 CONTINUE +C + CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, + $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), + $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, US(N+1,N+1), + $ LDUS, IERR ) +C + ELSE IF ( ( .NOT.LUS ).AND.LUU ) THEN +C +C Workspace requirements: MAX( 2*N*N + 2*N, 8*N ) +C + CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, + $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, + $ U2, LDU2, V1, LDV1, V2, LDV2, UU, LDUU, WR, + $ WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) + $ GO TO 250 + CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, + $ UU(N+1,N+1), LDUU, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(1,N+1), LDUU, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + DO 120 J = 1, N + CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) + 120 CONTINUE + PDW = 2*N*N+1 +C +C DW <- -[V1;V2]*W11 +C + CALL DLACPY( 'All', N, N, V1, LDV1, DWORK, 2*N ) + CALL DLACPY( 'All', N, N, V2, LDV2, DWORK(N+1), 2*N ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, -ONE, + $ UU, LDUU, DWORK, 2*N, DWORK(PDW), LDWORK-PDW+1, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(PDW) ) + PDW - 1 ) +C +C DW2 <- DW2 - U2*W21 +C + CALL DLACPY( 'All', N, N, U2, LDU2, UU, LDUU ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, -ONE, + $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + DO 130 J = 1, N + CALL DAXPY( N, ONE, UU(1,J), 1, DWORK(N+2*(J-1)*N+1), 1 ) + 130 CONTINUE +C +C UU11 <- U1*W21 - DW1 +C + CALL DLACPY( 'All', N, N, U1, LDU1, UU, LDUU ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', N, N, ONE, + $ UU(N+1,1), LDUU, UU, LDUU, DWORK(PDW), + $ LDWORK-PDW+1, IERR ) + DO 140 J = 1, N + CALL DAXPY( N, -ONE, DWORK(2*(J-1)*N+1), 1, UU(1,J), 1 ) + 140 CONTINUE +C +C UU21 <- DW2 +C + CALL DLACPY( 'All', N, N, DWORK(N+1), 2*N, UU(N+1,1), LDUU ) +C + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(1,N+1), LDUU, V1, LDV1, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(1,N+1), LDUU, V2, LDV2, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(N+1,N+1), LDUU, U1, LDU1, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ UU(N+1,N+1), LDUU, U2, LDU2, DWORK, LDWORK, + $ IERR ) + CALL DLACPY( 'All', N, N, V1, LDV1, UU(1,N+1), LDUU ) + CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,N+1), LDUU ) + DO 150 J = 1, N + CALL DAXPY( N, ONE, U1(1,J), 1, UU(1,N+J), 1 ) + 150 CONTINUE + DO 160 J = 1, N + CALL DAXPY( N, ONE, U2(1,J), 1, UU(N+1,N+J), 1 ) + 160 CONTINUE +C + CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, + $ S, LDS, G, LDG, UU(1,N+1), LDUU, UU(N+1,N+1), + $ LDUU, WR, WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, N, UU(N+1,N+1), + $ LDUU, IERR ) + ELSE +C +C Workspace requirements: 8*N +C + CALL MB03ZA( 'Update', 'Update', 'Update', 'Init', WHICH, + $ SELECT, N, S, LDS, T, LDT, G, LDG, U1, LDU1, + $ U2, LDU2, V1, LDV1, V2, LDV2, US, LDUS, WR, + $ WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) + $ GO TO 250 + CALL MB01UX( 'Left', 'Lower', 'Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, G, LDG, DWORK, LDWORK, + $ IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + DO 170 J = 1, N + CALL DAXPY( J, ONE, G(J,1), LDG, G(1,J), 1 ) + 170 CONTINUE +C +C UU = [ V1 -V2; U1 -U2 ]*diag(W11,W21) +C + CALL DLACPY( 'All', N, N, V1, LDV1, UU, LDUU ) + CALL DLACPY( 'All', N, N, V2, LDV2, UU(N+1,1), LDUU ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, + $ US, LDUS, UU, LDUU, DWORK, LDWORK, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL DLACPY( 'All', N, N, U1, LDU1, UU(1,N+1), LDUU ) + CALL DLACPY( 'All', N, N, U2, LDU2, UU(N+1,N+1), LDUU ) + CALL MB01UX( 'Right', 'Upper', 'No Transpose', 2*N, N, ONE, + $ US(N+1,1), LDUS, UU(1,N+1), LDUU, DWORK, + $ LDWORK, IERR ) + CALL DLASCL( 'General', 0, 0, ONE, -ONE, N, 2*N, UU(N+1,1), + $ LDUU, IERR ) +C + CALL DLACPY( 'All', 2*N, N, UU, LDUU, US, LDUS ) + DO 180 J = 1, N + CALL DAXPY( 2*N, -ONE, UU(1,N+J), 1, US(1,J), 1 ) + 180 CONTINUE + DO 190 J = 1, N + CALL DAXPY( 2*N, ONE, UU(1,N+J), 1, UU(1,J), 1 ) + 190 CONTINUE +C +C V1 <- V1*W12-U1*W22 +C U1 <- V1*W12+U1*W22 +C V2 <- V2*W12-U2*W22 +C U2 <- V2*W12+U2*W22 +C + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, V1, LDV1, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(1,N+1), LDUS, V2, LDV2, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, U1, LDU1, DWORK, LDWORK, + $ IERR ) + CALL MB01UX( 'Right', 'Lower', 'No Transpose', N, N, ONE, + $ US(N+1,N+1), LDUS, U2, LDU2, DWORK, LDWORK, + $ IERR ) + DO 210 J = 1, N + DO 200 I = 1, N + TEMP = V1(I,J) + V1(I,J) = TEMP - U1(I,J) + U1(I,J) = TEMP + U1(I,J) + 200 CONTINUE + 210 CONTINUE + DO 230 J = 1, N + DO 220 I = 1, N + TEMP = V2(I,J) + V2(I,J) = TEMP - U2(I,J) + U2(I,J) = TEMP + U2(I,J) + 220 CONTINUE + 230 CONTINUE +C + CALL DLASET( 'All', 2*N, N, ZERO, ONE, US(1,N+1), LDUS ) + CALL MB03TD( 'Hamiltonian', 'Update', LWORK, LWORK(N+1), N, + $ S, LDS, G, LDG, US(1,N+1), LDUS, US(N+1,N+1), + $ LDUS, WR, WI, M, DWORK, LDWORK, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ U1, LDU1, US(1,N+1), LDUS, ZERO, UU(1,N+1), + $ LDUU ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ U2, LDU2, US(N+1,N+1), LDUS, ONE, UU(1,N+1), + $ LDUU ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ U1, LDU1, US(N+1,N+1), LDUS, ZERO, UU(N+1,N+1), + $ LDUU ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ U2, LDU2, US(1,N+1), LDUS, ONE, UU(N+1,N+1), + $ LDUU ) + CALL DLACPY( 'All', N, N, US(1,N+1), LDUS, U1, LDU1 ) + CALL DLACPY( 'All', N, N, US(N+1,N+1), LDUS, U2, LDU2 ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, ONE, + $ V1, LDV1, U1, LDU1, ZERO, US(1,N+1), LDUS ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ V2, LDV2, U2, LDU2, ONE, US(1,N+1), LDUS ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ V1, LDV1, U2, LDU2, ZERO, US(N+1,N+1), LDUS ) + CALL DGEMM( 'No Transpose', 'No Transpose', N, N, N, -ONE, + $ V2, LDV2, U1, LDU1, ONE, US(N+1,N+1), LDUS ) + END IF +C +C Orthonormalize obtained bases and apply inverse balancing +C transformation. +C + IF ( LBAL .AND. LBEF ) THEN + IF ( LUS ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, + $ LDUS, US(N+1,1), LDUS, IERR ) + IF ( LUU ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, + $ LDUU, UU(N+1,1), LDUU, IERR ) + END IF +C +C Workspace requirements: 8*N+1 +C + DO 240 J = 1, 2*N + IWORK(J) = 0 + 240 CONTINUE + IF ( LUS ) THEN + CALL DGEQP3( 2*N, 2*N, US, LDUS, IWORK, DWORK, DWORK(2*N+1), + $ LDWORK-2*N, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) + CALL DORGQR( 2*N, 2*N, N, US, LDUS, DWORK, DWORK(2*N+1), + $ LDWORK-2*N, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) + END IF + IF ( LUU ) THEN + CALL DGEQP3( 2*N, 2*N, UU, LDUU, IWORK, DWORK, DWORK(2*N+1), + $ LDWORK-2*N, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) + CALL DORGQR( 2*N, 2*N, N, UU, LDUU, DWORK, DWORK(2*N+1), + $ LDWORK-2*N, IERR ) + WRKOPT = MAX( WRKOPT, INT( DWORK(2*N+1) ) + 2*N ) + END IF +C + IF ( LBAL .AND. .NOT.LBEF ) THEN + IF ( LUS ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, US, + $ LDUS, US(N+1,1), LDUS, IERR ) + IF ( LUU ) + $ CALL MB04DI( BALANC, 'Positive', N, ILO, SCALE, N, UU, + $ LDUU, UU(N+1,1), LDUU, IERR ) + END IF + END IF +C + CALL DSCAL( M, -ONE, WR, 1 ) + DWORK(1) = DBLE( WRKOPT ) +C + RETURN + 250 CONTINUE + IF ( IERR.EQ.1 ) THEN + INFO = 2 + ELSE IF ( IERR.EQ.2 .OR. IERR.EQ.4 ) THEN + INFO = 1 + ELSE IF ( IERR.EQ.3 ) THEN + INFO = 3 + END IF + RETURN +C *** Last line of MB03ZD *** + END diff --git a/mex/sources/libslicot/MB04DD.f b/mex/sources/libslicot/MB04DD.f new file mode 100644 index 000000000..857bceef0 --- /dev/null +++ b/mex/sources/libslicot/MB04DD.f @@ -0,0 +1,440 @@ + SUBROUTINE MB04DD( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To balance a real Hamiltonian matrix, +C +C [ A G ] +C H = [ T ] , +C [ Q -A ] +C +C where A is an N-by-N matrix and G, Q are N-by-N symmetric +C matrices. This involves, first, permuting H by a symplectic +C similarity transformation to isolate eigenvalues in the first +C 1:ILO-1 elements on the diagonal of A; and second, applying a +C diagonal similarity transformation to rows and columns +C ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm +C as possible. Both steps are optional. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the operations to be performed on H: +C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; +C = 'P': permute only; +C = 'S': scale only; +C = 'B': both permute and scale. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix A of the balanced Hamiltonian. In particular, +C the lower triangular part of the first ILO-1 columns of A +C is zero. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain the lower triangular part of the matrix Q and +C the upper triangular part of the matrix G. +C On exit, the leading N-by-N+1 part of this array contains +C the lower and upper triangular parts of the matrices Q and +C G, respectively, of the balanced Hamiltonian. In +C particular, the lower triangular and diagonal part of the +C first ILO-1 columns of QG is zero. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C ILO (output) INTEGER +C ILO-1 is the number of deflated eigenvalues in the +C balanced Hamiltonian matrix. +C +C SCALE (output) DOUBLE PRECISION array of dimension (N) +C Details of the permutations and scaling factors applied to +C H. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, +C then rows and columns P(j) and P(j)+N are interchanged +C with rows and columns j and j+N, respectively. If +C P(j) > N, then row and column P(j)-N are interchanged with +C row and column j+N by a generalized symplectic +C permutation. For j = ILO,...,N the j-th element of SCALE +C contains the factor of the scaling applied to row and +C column j. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Benner, P. +C Symplectic balancing of Hamiltonian matrices. +C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAL). +C +C KEYWORDS +C +C Balancing, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER ILO, INFO, LDA, LDQG, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) +C .. Local Scalars .. + LOGICAL CONV, LPERM, LSCAL + INTEGER I, IC, ILOOLD, J + DOUBLE PRECISION C, F, GII, MAXC, MAXR, QII, R, SCLFAC, + $ SFMAX1, SFMAX2, SFMIN1, SFMIN2, TEMP +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) + LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) +C + IF ( .NOT.LPERM .AND. .NOT.LSCAL + $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN + INFO = -1 + ELSE IF ( N.LT.0 ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF +C +C Return if there were illegal values. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04DD', -INFO ) + RETURN + END IF +C + ILO = 1 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN + IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN + DO 10 I = 1, N + SCALE(I) = ONE + 10 CONTINUE + RETURN + END IF +C +C Permutations to isolate eigenvalues if possible. +C + IF ( LPERM ) THEN + ILOOLD = 0 +C WHILE ( ILO.NE.ILOOLD ) + 20 IF ( ILO.NE.ILOOLD ) THEN + ILOOLD = ILO +C +C Scan columns ILO .. N. +C + I = ILO +C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) + 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN + DO 40 J = ILO, I-1 + IF ( A(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 40 CONTINUE + DO 50 J = I+1, N + IF ( A(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 50 CONTINUE + DO 60 J = ILO, I + IF ( QG(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 60 CONTINUE + DO 70 J = I+1, N + IF ( QG(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 70 CONTINUE +C +C Exchange columns/rows ILO <-> I. +C + SCALE( ILO ) = DBLE( I ) + IF ( ILO.NE.I ) THEN +C + CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) + CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) +C + CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) + CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) + CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) +C + CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) + CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), + $ LDQG ) + CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), + $ 1 ) + END IF + ILO = ILO + 1 + END IF +C END WHILE 30 +C +C Scan columns N+ILO .. 2*N. +C + I = ILO +C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) + 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN + DO 90 J = ILO, I-1 + IF ( A(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 90 CONTINUE + DO 100 J = I+1, N + IF ( A(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 100 CONTINUE + DO 110 J = ILO, I + IF ( QG(J,I+1).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 110 CONTINUE + DO 120 J = I+1, N + IF ( QG(I,J+1).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 120 CONTINUE + SCALE( ILO ) = DBLE( N+I ) +C +C Exchange columns/rows I <-> I+N with a symplectic +C generalized permutation. +C + CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) + CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) + CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) + CALL DSCAL( N-I, -ONE, A(I,I+1), LDA ) + CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) + CALL DSCAL( I-1, -ONE, A(1,I), 1 ) + CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) + CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) + A(I,I) = -A(I,I) + TEMP = QG(I,I) + QG(I,I) = -QG(I,I+1) + QG(I,I+1) = -TEMP +C +C Exchange columns/rows ILO <-> I. +C + IF ( ILO.NE.I ) THEN +C + CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) + CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) +C + CALL DSWAP( 1, QG(I,ILO), LDQG, QG(ILO,ILO), LDQG ) + CALL DSWAP( N-I+1, QG(I,I), 1, QG(I,ILO), 1 ) + CALL DSWAP( I-ILO, QG(ILO,ILO), 1, QG(I,ILO), LDQG ) +C + CALL DSWAP( ILO, QG(1,I+1), 1, QG(1,ILO+1), 1 ) + CALL DSWAP( N-I+1, QG(I,I+1), LDQG, QG(ILO,I+1), + $ LDQG ) + CALL DSWAP( I-ILO, QG(ILO,ILO+1), LDQG, QG(ILO,I+1), + $ 1 ) + END IF + ILO = ILO + 1 + END IF +C END WHILE 80 + GOTO 20 + END IF +C END WHILE 20 + END IF +C + DO 130 I = ILO, N + SCALE(I) = ONE + 130 CONTINUE +C +C Scale to reduce the 1-norm of the remaining blocks. +C + IF ( LSCAL ) THEN + SCLFAC = DLAMCH( 'B' ) + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C +C Scale the rows and columns one at a time to minimize the +C 1-norm of the remaining Hamiltonian submatrix. +C Stop when the 1-norm is very roughly minimal. +C + 140 CONTINUE + CONV = .TRUE. + DO 170 I = ILO, N +C +C Compute 1-norm of row and column I without diagonal +C elements. +C + R = DASUM( I-ILO, A(I,ILO), LDA ) + + $ DASUM( N-I, A(I,I+1), LDA ) + + $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + + $ DASUM( N-I, QG(I,I+2), LDQG ) + C = DASUM( I-ILO, A(ILO,I), 1 ) + + $ DASUM( N-I, A(I+1,I), 1 ) + + $ DASUM( I-ILO, QG(I,ILO), LDQG ) + + $ DASUM( N-I, QG(I+1,I), 1 ) + QII = ABS( QG(I,I) ) + GII = ABS( QG(I,I+1) ) +C +C Compute inf-norms of row and column I. +C + IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) + MAXR = ABS( A(I,IC+ILO-1) ) + IF ( I.GT.1 ) THEN + IC = IDAMAX( I-1, QG(1,I+1), 1 ) + MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) + END IF + IF ( N.GT.I ) THEN + IC = IDAMAX( N-I, QG(I,I+2), LDQG ) + MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) + END IF + IC = IDAMAX( N, A(1,I), 1 ) + MAXC = ABS( A(IC,I) ) + IF ( I.GT.ILO ) THEN + IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) + MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) + END IF + IF ( N.GT.I ) THEN + IC = IDAMAX( N-I, QG(I+1,I), 1 ) + MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) + END IF + IF ( ( C + QII ).EQ.ZERO .OR. ( R + GII ).EQ.ZERO ) + $ GO TO 170 +C + F = ONE + 150 CONTINUE + IF ( ( ( R + GII/SCLFAC )/SCLFAC ).GE. + $ ( ( C + QII*SCLFAC )*SCLFAC ) .AND. + $ MAX( F*SCLFAC, C*SCLFAC, MAXC*SCLFAC, + $ QII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. + $ MIN( ( R + GII/SCLFAC )/SCLFAC, MAX( MAXR/SCLFAC, + $ GII/SCLFAC/SCLFAC ) ).GT.SFMIN2 ) THEN + F = F*SCLFAC + C = C*SCLFAC + QII = QII*SCLFAC*SCLFAC + R = R / SCLFAC + GII = GII/SCLFAC/SCLFAC + MAXC = MAXC*SCLFAC + MAXR = MAXR / SCLFAC + GO TO 150 + END IF +C + 160 CONTINUE + IF ( ( ( R + GII*SCLFAC )*SCLFAC ).LE. + $ ( ( C + QII/SCLFAC )/SCLFAC ) .AND. + $ MAX( R*SCLFAC, MAXR*SCLFAC, + $ GII*SCLFAC*SCLFAC ).LT.SFMAX2 .AND. + $ MIN( F/SCLFAC, ( C + QII/SCLFAC )/SCLFAC, + $ MAX( MAXC/SCLFAC, QII/SCLFAC/SCLFAC ) ) + $ .GT.SFMIN2 ) THEN + F = F / SCLFAC + C = C / SCLFAC + QII = QII/SCLFAC/SCLFAC + R = R*SCLFAC + GII = GII*SCLFAC*SCLFAC + MAXC = MAXC/SCLFAC + MAXR = MAXR*SCLFAC + GO TO 160 + END IF +C +C Now balance if necessary. +C + IF ( F.NE.ONE ) THEN + IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN + IF ( F*SCALE(I).LE.SFMIN1 ) + $ GO TO 170 + END IF + IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN + IF ( SCALE(I).GE.SFMAX1 / F ) + $ GO TO 170 + END IF + CONV = .FALSE. + SCALE(I) = SCALE(I)*F + CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) + CALL DRSCL( N-I, F, A(I,I+1), LDA ) + CALL DSCAL( I-1, F, A(1,I), 1 ) + CALL DSCAL( N-I, F, A(I+1,I), 1 ) + CALL DRSCL( I-1, F, QG(1,I+1), 1 ) + QG(I,I+1) = QG(I,I+1) / F / F + CALL DRSCL( N-I, F, QG(I,I+1+1), LDQG ) + CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) + QG(I,I) = QG(I,I) * F * F + CALL DSCAL( N-I, F, QG(I+1,I), 1 ) + END IF + 170 CONTINUE + IF ( .NOT.CONV ) GO TO 140 + END IF + RETURN +C *** Last line of MB04DD *** + END diff --git a/mex/sources/libslicot/MB04DI.f b/mex/sources/libslicot/MB04DI.f new file mode 100644 index 000000000..793d6ab5a --- /dev/null +++ b/mex/sources/libslicot/MB04DI.f @@ -0,0 +1,216 @@ + SUBROUTINE MB04DI( JOB, SGN, N, ILO, SCALE, M, V1, LDV1, V2, LDV2, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the inverse of a balancing transformation, computed by +C the SLICOT Library routines MB04DD or MB04DS, to a 2*N-by-M matrix +C +C [ V1 ] +C [ ], +C [ sgn*V2 ] +C +C where sgn is either +1 or -1. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the type of inverse transformation required: +C = 'N': do nothing, return immediately; +C = 'P': do inverse transformation for permutation only; +C = 'S': do inverse transformation for scaling only; +C = 'B': do inverse transformations for both permutation +C and scaling. +C JOB must be the same as the argument JOB supplied to +C MB04DD or MB04DS. +C +C SGN CHARACTER*1 +C Specifies the sign to use for V2: +C = 'P': sgn = +1; +C = 'N': sgn = -1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrices V1 and V2. N >= 0. +C +C ILO (input) INTEGER +C The integer ILO determined by MB04DD or MB04DS. +C 1 <= ILO <= N+1. +C +C SCALE (input) DOUBLE PRECISION array, dimension (N) +C Details of the permutation and scaling factors, as +C returned by MB04DD or MB04DS. +C +C M (input) INTEGER +C The number of columns of the matrices V1 and V2. M >= 0. +C +C V1 (input/output) DOUBLE PRECISION array, dimension (LDV1,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix V1. +C On exit, the leading N-by-M part of this array is +C overwritten by the updated matrix V1 of the transformed +C matrix. +C +C LDV1 INTEGER +C The leading dimension of the array V1. LDV1 >= max(1,N). +C +C V2 (input/output) DOUBLE PRECISION array, dimension (LDV2,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix V2. +C On exit, the leading N-by-M part of this array is +C overwritten by the updated matrix V2 of the transformed +C matrix. +C +C LDV2 INTEGER +C The leading dimension of the array V2. LDV2 >= max(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Benner, P. +C Symplectic balancing of Hamiltonian matrices. +C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DHABAK). +C +C KEYWORDS +C +C Balancing, Hamiltonian matrix, skew-Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB, SGN + INTEGER ILO, INFO, LDV1, LDV2, M, N +C .. Array Arguments .. + DOUBLE PRECISION SCALE(*), V1(LDV1,*), V2(LDV2,*) +C .. Local Scalars .. + LOGICAL LPERM, LSCAL, LSGN, SYSW + INTEGER I, K +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) + LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) + LSGN = LSAME( SGN, 'N' ) + IF ( .NOT.LPERM .AND. .NOT.LSCAL + $ .AND. .NOT.LSAME( JOB, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.LSGN .AND. .NOT.LSAME( SGN, 'P' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.N+1 ) THEN + INFO = -4 + ELSE IF ( M.LT.0 ) THEN + INFO = -6 + ELSE IF ( LDV1.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDV2.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04DI', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 .OR. LSAME( JOB, 'N' ) ) + $ RETURN +C +C Inverse scaling. +C + IF ( LSCAL ) THEN + DO 20 I = ILO, N + CALL DRSCL( M, SCALE(I), V1(I,1), LDV1 ) + 20 CONTINUE + DO 30 I = ILO, N + CALL DRSCL( M, SCALE(I), V2(I,1), LDV2 ) + 30 CONTINUE + END IF +C +C Inverse permutation. +C + IF ( LPERM ) THEN + DO 40 I = ILO-1, 1, -1 + K = SCALE( I ) + SYSW = ( K.GT.N ) + IF ( SYSW ) + $ K = K - N +C + IF ( K.NE.I ) THEN +C +C Exchange rows k <-> i. +C + CALL DSWAP( M, V1(I,1), LDV1, V1(K,1), LDV1 ) + CALL DSWAP( M, V2(I,1), LDV2, V2(K,1), LDV2 ) + END IF +C + IF ( SYSW ) THEN +C +C Exchange V1(k,:) <-> V2(k,:). +C + CALL DSWAP( M, V1(K,1), LDV1, V2(K,1), LDV2 ) + IF ( LSGN ) THEN + CALL DSCAL( M, -ONE, V2(K,1), LDV2 ) + ELSE + CALL DSCAL( M, -ONE, V1(K,1), LDV1 ) + END IF + END IF + 40 CONTINUE + END IF +C + RETURN +C *** Last line of MB04DI *** + END diff --git a/mex/sources/libslicot/MB04DS.f b/mex/sources/libslicot/MB04DS.f new file mode 100644 index 000000000..f543a97d1 --- /dev/null +++ b/mex/sources/libslicot/MB04DS.f @@ -0,0 +1,450 @@ + SUBROUTINE MB04DS( JOB, N, A, LDA, QG, LDQG, ILO, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To balance a real skew-Hamiltonian matrix +C +C [ A G ] +C S = [ T ] , +C [ Q A ] +C +C where A is an N-by-N matrix and G, Q are N-by-N skew-symmetric +C matrices. This involves, first, permuting S by a symplectic +C similarity transformation to isolate eigenvalues in the first +C 1:ILO-1 elements on the diagonal of A; and second, applying a +C diagonal similarity transformation to rows and columns +C ILO:2*N-ILO+1 to make the rows and columns as close in 1-norm +C as possible. Both steps are optional. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the operations to be performed on S: +C = 'N': none, set ILO = 1, SCALE(I) = 1.0, I = 1 .. N; +C = 'P': permute only; +C = 'S': scale only; +C = 'B': both permute and scale. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix A of the balanced skew-Hamiltonian. In +C particular, the lower triangular part of the first ILO-1 +C columns of A is zero. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N) +C On entry, the leading N-by-N+1 part of this array must +C contain in columns 1:N the strictly lower triangular part +C of the matrix Q and in columns 2:N+1 the strictly upper +C triangular part of the matrix G. The parts containing the +C diagonal and the first supdiagonal of this array are not +C referenced. +C On exit, the leading N-by-N+1 part of this array contains +C the strictly lower and strictly upper triangular parts of +C the matrices Q and G, respectively, of the balanced +C skew-Hamiltonian. In particular, the strictly lower +C triangular part of the first ILO-1 columns of QG is zero. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C ILO (output) INTEGER +C ILO-1 is the number of deflated eigenvalues in the +C balanced skew-Hamiltonian matrix. +C +C SCALE (output) DOUBLE PRECISION array of dimension (N) +C Details of the permutations and scaling factors applied to +C S. For j = 1,...,ILO-1 let P(j) = SCALE(j). If P(j) <= N, +C then rows and columns P(j) and P(j)+N are interchanged +C with rows and columns j and j+N, respectively. If +C P(j) > N, then row and column P(j)-N are interchanged with +C row and column j+N by a generalized symplectic +C permutation. For j = ILO,...,N the j-th element of SCALE +C contains the factor of the scaling applied to row and +C column j. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Benner, P. +C Symplectic balancing of Hamiltonian matrices. +C SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2000. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DSHBAL). +C +C KEYWORDS +C +C Balancing, skew-Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + DOUBLE PRECISION FACTOR + PARAMETER ( FACTOR = 0.95D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER ILO, INFO, LDA, LDQG, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), QG(LDQG,*), SCALE(*) +C .. Local Scalars .. + LOGICAL CONV, LPERM, LSCAL + INTEGER I, IC, ILOOLD, J + DOUBLE PRECISION C, F, G, MAXC, MAXR, R, S, SCLFAC, SFMAX1, + $ SFMAX2, SFMIN1, SFMIN2 +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DRSCL, DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) + LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) +C + IF ( .NOT.LPERM .AND. .NOT.LSCAL .AND. + $ .NOT.LSAME( JOB, 'N' ) ) THEN + INFO = -1 + ELSE IF ( N.LT.0 ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF +C +C Return if there were illegal values. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04DS', -INFO ) + RETURN + END IF +C + ILO = 1 +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN + IF ( .NOT.LPERM .AND. .NOT.LSCAL ) THEN + DO 10 I = 1, N + SCALE(I) = ONE + 10 CONTINUE + RETURN + END IF +C +C Permutations to isolate eigenvalues if possible. +C + IF ( LPERM ) THEN + ILOOLD = 0 +C WHILE ( ILO.NE.ILOOLD ) + 20 IF ( ILO.NE.ILOOLD ) THEN + ILOOLD = ILO +C +C Scan columns ILO .. N. +C + I = ILO +C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) + 30 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN + DO 40 J = ILO, I-1 + IF ( A(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 40 CONTINUE + DO 50 J = I+1, N + IF ( A(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 50 CONTINUE + DO 60 J = ILO, I-1 + IF ( QG(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 60 CONTINUE + DO 70 J = I+1, N + IF ( QG(J,I).NE.ZERO ) THEN + I = I + 1 + GOTO 30 + END IF + 70 CONTINUE +C +C Exchange columns/rows ILO <-> I. +C + SCALE(ILO) = DBLE( I ) + IF ( ILO.NE.I ) THEN +C + CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) + CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) +C + IF ( I.LT.N ) + $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) + IF ( I.GT.ILO+1 ) THEN + CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) + CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), + $ LDQG ) + END IF +C + CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) + IF ( N.GT.I ) + $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), + $ LDQG ) + IF ( I.GT.ILO+1 ) THEN + CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) + CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, + $ QG(ILO+1,I+1), 1 ) + END IF + CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) + END IF + ILO = ILO + 1 + END IF +C END WHILE 30 +C +C Scan columns N+ILO .. 2*N. +C + I = ILO +C WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD ) + 80 IF ( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN + DO 90 J = ILO, I-1 + IF ( A(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 90 CONTINUE + DO 100 J = I+1, N + IF ( A(I,J).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 100 CONTINUE + DO 110 J = ILO, I-1 + IF ( QG(J,I+1).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 110 CONTINUE + DO 120 J = I+1, N + IF ( QG(I,J+1).NE.ZERO ) THEN + I = I + 1 + GOTO 80 + END IF + 120 CONTINUE + SCALE(ILO) = DBLE( N+I ) +C +C Exchange columns/rows I <-> I+N with a symplectic +C generalized permutation. +C + CALL DSWAP( I-ILO, A(I,ILO), LDA, QG(I,ILO), LDQG ) + CALL DSCAL( I-ILO, -ONE, A(I,ILO), LDA ) + CALL DSWAP( N-I, A(I,I+1), LDA, QG(I+1,I), 1 ) + CALL DSCAL( N-I, -ONE, QG(I+1,I), 1 ) + CALL DSWAP( I-1, A(1,I), 1, QG(1,I+1), 1 ) + CALL DSCAL( I-1, -ONE, A(1,I), 1 ) + CALL DSCAL( N-I, -ONE, A(I+1,I), 1 ) + CALL DSWAP( N-I, A(I+1,I), 1, QG(I,I+2), LDQG ) +C +C Exchange columns/rows ILO <-> I. +C + IF ( ILO.NE.I ) THEN +C + CALL DSWAP( N, A(1,ILO), 1, A(1,I), 1 ) + CALL DSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA ) +C + IF ( I.LT.N ) + $ CALL DSWAP( N-I, QG(I+1,I), 1, QG(I+1,ILO), 1 ) + IF ( I.GT.ILO+1 ) THEN + CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,ILO), 1 ) + CALL DSWAP( I-ILO-1, QG(ILO+1,ILO), 1, QG(I,ILO+1), + $ LDQG ) + END IF +C + CALL DSWAP( ILO-1, QG(1,I+1), 1, QG(1,ILO+1), 1 ) + IF ( N.GT.I ) + $ CALL DSWAP( N-I, QG(I,I+2), LDQG, QG(ILO,I+2), + $ LDQG ) + IF ( I.GT.ILO+1 ) THEN + CALL DSCAL( I-ILO-1, -ONE, QG(ILO+1,I+1), 1 ) + CALL DSWAP( I-ILO-1, QG(ILO,ILO+2), LDQG, + $ QG(ILO+1,I+1), 1 ) + END IF + CALL DSCAL( I-ILO, -ONE, QG(ILO,I+1), 1 ) + END IF + ILO = ILO + 1 + END IF +C END WHILE 80 + GOTO 20 + END IF +C END WHILE 20 + END IF +C + DO 130 I = ILO, N + SCALE(I) = ONE + 130 CONTINUE +C +C Scale to reduce the 1-norm of the remaining blocks. +C + IF ( LSCAL ) THEN + SCLFAC = DLAMCH( 'B' ) + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C +C Scale the rows and columns one at a time to minimize the +C 1-norm of the skew-Hamiltonian submatrix. +C Stop when the 1-norm is very roughly minimal. +C + 140 CONTINUE + CONV = .TRUE. + DO 190 I = ILO, N +C +C Compute 1-norm of row and column I without diagonal +C elements. +C + R = DASUM( I-ILO, A(I,ILO), LDA ) + + $ DASUM( N-I, A(I,I+1), LDA ) + + $ DASUM( I-ILO, QG(ILO,I+1), 1 ) + + $ DASUM( N-I, QG(I,I+2), LDQG ) + C = DASUM( I-ILO, A(ILO,I), 1 ) + + $ DASUM( N-I, A(I+1,I), 1 ) + + $ DASUM( I-ILO, QG(I,ILO), LDQG ) + + $ DASUM( N-I, QG(I+1,I), 1 ) +C +C Compute inf-norms of row and column I. +C + IC = IDAMAX( N-ILO+1, A(I,ILO), LDA ) + MAXR = ABS( A(I,IC+ILO-1) ) + IF ( I.GT.1 ) THEN + IC = IDAMAX( I-1, QG(1,I+1), 1 ) + MAXR = MAX( MAXR, ABS( QG(IC,I+1) ) ) + END IF + IF ( N.GT.I ) THEN + IC = IDAMAX( N-I, QG(I,I+2), LDQG ) + MAXR = MAX( MAXR, ABS( QG(I,IC+I+1) ) ) + END IF + IC = IDAMAX( N, A(1,I), 1 ) + MAXC = ABS( A(IC,I) ) + IF ( I.GT.ILO ) THEN + IC = IDAMAX( I-ILO, QG(I,ILO), LDQG ) + MAXC = MAX( MAXC, ABS( QG(I,IC+ILO-1) ) ) + END IF + IF ( N.GT.I ) THEN + IC = IDAMAX( N-I, QG(I+1,I), 1 ) + MAXC = MAX( MAXC, ABS( QG(IC+I,I) ) ) + END IF +C + IF ( C.EQ.ZERO .OR. R.EQ.ZERO ) + $ GOTO 190 + G = R / SCLFAC + F = ONE + S = C + R + 150 CONTINUE + IF ( C.GE.G .OR. MAX( F, C, MAXC ).GE.SFMAX2 .OR. + $ MIN( R, G, MAXR ).LE.SFMIN2 ) + $ GOTO 160 + F = F*SCLFAC + G = G / SCLFAC + C = C*SCLFAC + R = R / SCLFAC + MAXC = MAXC*SCLFAC + MAXR = MAXR / SCLFAC + GOTO 150 +C + 160 CONTINUE + G = C / SCLFAC + 170 CONTINUE + IF ( G.LT.R .OR. MAX( R, MAXR ).GE.SFMAX2 .OR. + $ MIN( F, C, G, MAXC ).LE.SFMIN2 ) + $ GOTO 180 + F = F / SCLFAC + G = G / SCLFAC + C = C / SCLFAC + R = R*SCLFAC + MAXC = MAXC / SCLFAC + MAXR = MAXR*SCLFAC + GOTO 170 +C + 180 CONTINUE +C +C Now balance if necessary. +C + IF ( ( C+R ).GE.FACTOR*S ) + $ GOTO 190 + IF ( F.LT.ONE .AND. SCALE(I).LT.ONE ) THEN + IF ( F*SCALE(I).LE.SFMIN1 ) + $ GOTO 190 + END IF + IF ( F.GT.ONE .AND. SCALE(I).GT.ONE ) THEN + IF ( SCALE(I).GE.SFMAX1 / F ) + $ GOTO 190 + END IF + CONV = .FALSE. + SCALE(I) = SCALE(I)*F + CALL DRSCL( I-ILO, F, A(I,ILO), LDA ) + CALL DRSCL( N-I, F, A(I,I+1), LDA ) + CALL DSCAL( I-1, F, A(1,I), 1 ) + CALL DSCAL( N-I, F, A(I+1,I), 1 ) + CALL DRSCL( I-1, F, QG(1,I+1), 1 ) + CALL DRSCL( N-I, F, QG(I,I+2), LDQG ) + CALL DSCAL( I-ILO, F, QG(I,ILO), LDQG ) + CALL DSCAL( N-I, F, QG(I+1,I), 1 ) + 190 CONTINUE + IF ( .NOT.CONV ) GOTO 140 + END IF + RETURN +C *** Last line of MB04DS *** + END diff --git a/mex/sources/libslicot/MB04DY.f b/mex/sources/libslicot/MB04DY.f new file mode 100644 index 000000000..6b8b3203d --- /dev/null +++ b/mex/sources/libslicot/MB04DY.f @@ -0,0 +1,329 @@ + SUBROUTINE MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform a symplectic scaling on the Hamiltonian matrix +C +C ( A G ) +C H = ( T ), (1) +C ( Q -A ) +C +C i.e., perform either the symplectic scaling transformation +C +C -1 +C ( A' G' ) ( D 0 ) ( A G ) ( D 0 ) +C H' <-- ( T ) = ( ) ( T ) ( -1 ), (2) +C ( Q' -A' ) ( 0 D ) ( Q -A ) ( 0 D ) +C +C where D is a diagonal scaling matrix, or the symplectic norm +C scaling transformation +C +C ( A'' G'' ) 1 ( A G/tau ) +C H'' <-- ( T ) = --- ( T ), (3) +C ( Q'' -A'' ) tau ( tau Q -A ) +C +C where tau is a real scalar. Note that if tau is not equal to 1, +C then (3) is NOT a similarity transformation. The eigenvalues +C of H are then tau times the eigenvalues of H''. +C +C For symplectic scaling (2), D is chosen to give the rows and +C columns of A' approximately equal 1-norms and to give Q' and G' +C approximately equal norms. (See METHOD below for details.) For +C norm scaling, tau = MAX(1, ||A||, ||G||, ||Q||) where ||.|| +C denotes the 1-norm (column sum norm). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBSCL CHARACTER*1 +C Indicates which scaling strategy is used, as follows: +C = 'S' : do the symplectic scaling (2); +C = '1' or 'O': do the 1-norm scaling (3); +C = 'N' : do nothing; set INFO and return. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On input, if JOBSCL <> 'N', the leading N-by-N part of +C this array must contain the upper left block A of the +C Hamiltonian matrix H in (1). +C On output, if JOBSCL <> 'N', the leading N-by-N part of +C this array contains the leading N-by-N part of the scaled +C Hamiltonian matrix H' in (2) or H'' in (3), depending on +C the setting of JOBSCL. +C If JOBSCL = 'N', this array is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if JOBSCL <> 'N'; +C LDA >= 1, if JOBSCL = 'N'. +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On input, if JOBSCL <> 'N', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangle of the lower left symmetric block Q of the +C Hamiltonian matrix H in (1), and the N-by-N upper +C triangular part of the submatrix in the columns 2 to N+1 +C of this array must contain the upper triangle of the upper +C right symmetric block G of H in (1). +C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) +C and G(i,j) = G(j,i) is stored in QG(j,i+1). +C On output, if JOBSCL <> 'N', the leading N-by-N lower +C triangular part of this array contains the lower triangle +C of the lower left symmetric block Q' or Q'', and the +C N-by-N upper triangular part of the submatrix in the +C columns 2 to N+1 of this array contains the upper triangle +C of the upper right symmetric block G' or G'' of the scaled +C Hamiltonian matrix H' in (2) or H'' in (3), depending on +C the setting of JOBSCL. +C If JOBSCL = 'N', this array is not referenced. +C +C LDQG INTEGER +C The leading dimension of the array QG. +C LDQG >= MAX(1,N), if JOBSCL <> 'N'; +C LDQG >= 1, if JOBSCL = 'N'. +C +C D (output) DOUBLE PRECISION array, dimension (nd) +C If JOBSCL = 'S', then nd = N and D contains the diagonal +C elements of the diagonal scaling matrix in (2). +C If JOBSCL = '1' or 'O', then nd = 1 and D(1) is set to tau +C from (3). In this case, no other elements of D are +C referenced. +C If JOBSCL = 'N', this array is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C If JOBSCL = 'N', this array is not referenced. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, then the i-th argument had an illegal +C value. +C +C METHOD +C +C 1. Symplectic scaling (JOBSCL = 'S'): +C +C First, LAPACK subroutine DGEBAL is used to equilibrate the 1-norms +C of the rows and columns of A using a diagonal scaling matrix D_A. +C Then, H is similarily transformed by the symplectic diagonal +C matrix D1 = diag(D_A,D_A**(-1)). Next, the off-diagonal blocks of +C the resulting Hamiltonian matrix are equilibrated in the 1-norm +C using the symplectic diagonal matrix D2 of the form +C +C ( I/rho 0 ) +C D2 = ( ) +C ( 0 rho*I ) +C +C where rho is a real scalar. Thus, in (2), D = D1*D2. +C +C 2. Norm scaling (JOBSCL = '1' or 'O'): +C +C The norm of the matrices A and G of (1) is reduced by setting +C A := A/tau and G := G/(tau**2) where tau is the power of the +C base of the arithmetic closest to MAX(1, ||A||, ||G||, ||Q||) and +C ||.|| denotes the 1-norm. +C +C REFERENCES +C +C [1] Benner, P., Byers, R., and Barth, E. +C Fortran 77 Subroutines for Computing the Eigenvalues of +C Hamiltonian Matrices. I: The Square-Reduced Method. +C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. +C +C NUMERICAL ASPECTS +C +C For symplectic scaling, the complexity of the used algorithms is +C hard to estimate and depends upon how well the rows and columns of +C A in (1) are equilibrated. In one sweep, each row/column of A is +C scaled once, i.e., the cost of one sweep is N**2 multiplications. +C Usually, 3-6 sweeps are enough to equilibrate the norms of the +C rows and columns of a matrix. Roundoff errors are possible as +C LAPACK routine DGEBAL does NOT use powers of the machine base for +C scaling. The second stage (equilibrating ||G|| and ||Q||) requires +C N**2 multiplications. +C For norm scaling, 3*N**2 + O(N) multiplications are required and +C NO rounding errors occur as all multiplications are performed with +C powers of the machine base. +C +C CONTRIBUTOR +C +C P. Benner, Universitaet Bremen, Germany, and +C R. Byers, University of Kansas, Lawrence, USA. +C Aug. 1998, routine DHABL. +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998, SLICOT Library version. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2009. +C +C KEYWORDS +C +C Balancing, Hamiltonian matrix, norms, symplectic similarity +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDQG, N + CHARACTER JOBSCL +C .. +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), D(*), DWORK(*), QG(LDQG,*) +C .. +C .. Local Scalars .. + DOUBLE PRECISION ANRM, BASE, EPS, GNRM, OFL, QNRM, + $ RHO, SFMAX, SFMIN, TAU, UFL, Y + INTEGER I, IERR, IHI, ILO, J + LOGICAL NONE, NORM, SYMP +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGEBAL, DLABAD, DLASCL, DRSCL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C .. +C .. Executable Statements .. +C + INFO = 0 + SYMP = LSAME( JOBSCL, 'S' ) + NORM = LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) + NONE = LSAME( JOBSCL, 'N' ) +C + IF( .NOT.SYMP .AND. .NOT.NORM .AND. .NOT.NONE ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.1 .OR. ( .NOT.NONE .AND. LDA.LT.N ) ) THEN + INFO = -4 + ELSE IF( LDQG.LT.1 .OR. ( .NOT.NONE .AND. LDQG.LT.N ) ) THEN + INFO = -6 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04DY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. NONE ) + $ RETURN +C +C Set some machine dependant constants. +C + BASE = DLAMCH( 'Base' ) + EPS = DLAMCH( 'Precision' ) + UFL = DLAMCH( 'Safe minimum' ) + OFL = ONE/UFL + CALL DLABAD( UFL, OFL ) + SFMAX = ( EPS/BASE )/UFL + SFMIN = ONE/SFMAX +C + IF ( NORM ) THEN +C +C Compute norms. +C + ANRM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) + QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) + Y = MAX( ONE, ANRM, GNRM, QNRM ) + TAU = ONE +C +C WHILE ( TAU < Y ) DO + 10 CONTINUE + IF ( ( TAU.LT.Y ) .AND. ( TAU.LT.SQRT( SFMAX ) ) ) THEN + TAU = TAU*BASE + GO TO 10 + END IF +C END WHILE 10 + IF ( TAU.GT.ONE ) THEN + IF ( ABS( TAU/BASE - Y ).LT.ABS( TAU - Y ) ) + $ TAU = TAU/BASE + CALL DLASCL( 'General', 0, 0, TAU, ONE, N, N, A, LDA, IERR ) + CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, + $ IERR ) + CALL DLASCL( 'Upper', 0, 0, TAU, ONE, N, N, QG(1,2), LDQG, + $ IERR ) + END IF +C + D(1) = TAU +C + ELSE + CALL DGEBAL( 'Scale', N, A, LDA, ILO, IHI, D, IERR ) +C + DO 30 J = 1, N +C + DO 20 I = J, N + QG(I,J) = QG(I,J)*D(J)*D(I) + 20 CONTINUE +C + 30 CONTINUE +C + DO 50 J = 2, N + 1 +C + DO 40 I = 1, J - 1 + QG(I,J) = QG(I,J)/D(J-1)/D(I) + 40 CONTINUE +C + 50 CONTINUE +C + GNRM = DLANSY( '1-norm', 'Upper', N, QG(1,2), LDQG, DWORK ) + QNRM = DLANSY( '1-norm', 'Lower', N, QG, LDQG, DWORK ) + IF ( GNRM.EQ.ZERO ) THEN + IF ( QNRM.EQ.ZERO ) THEN + RHO = ONE + ELSE + RHO = SFMAX + END IF + ELSE IF ( QNRM.EQ.ZERO ) THEN + RHO = SFMIN + ELSE + RHO = SQRT( QNRM )/SQRT( GNRM ) + END IF +C + CALL DLASCL( 'Lower', 0, 0, RHO, ONE, N, N, QG, LDQG, IERR ) + CALL DLASCL( 'Upper', 0, 0, ONE, RHO, N, N, QG(1,2), LDQG, + $ IERR ) + CALL DRSCL( N, SQRT( RHO ), D, 1 ) + END IF +C + RETURN +C *** Last line of MB04DY *** + END diff --git a/mex/sources/libslicot/MB04GD.f b/mex/sources/libslicot/MB04GD.f new file mode 100644 index 000000000..fa7502ec6 --- /dev/null +++ b/mex/sources/libslicot/MB04GD.f @@ -0,0 +1,258 @@ + SUBROUTINE MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an RQ factorization with row pivoting of a +C real m-by-n matrix A: P*A = R*Q. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the m-by-n matrix A. +C On exit, +C if m <= n, the upper triangle of the subarray +C A(1:m,n-m+1:n) contains the m-by-m upper triangular +C matrix R; +C if m >= n, the elements on and above the (m-n)-th +C subdiagonal contain the m-by-n upper trapezoidal matrix R; +C the remaining elements, with the array TAU, represent the +C orthogonal matrix Q as a product of min(m,n) elementary +C reflectors (see METHOD). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C JPVT (input/output) INTEGER array, dimension (M) +C On entry, if JPVT(i) .ne. 0, the i-th row of A is permuted +C to the bottom of P*A (a trailing row); if JPVT(i) = 0, +C the i-th row of A is a free row. +C On exit, if JPVT(i) = k, then the i-th row of P*A +C was the k-th row of A. +C +C TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) +C The scalar factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit +C in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Based on LAPACK Library routines DGEQPF and DGERQ2. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Factorization, matrix algebra, matrix operations, orthogonal +C transformation, triangular form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +C .. +C .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), TAU( * ) +C .. +C .. Local Scalars .. + INTEGER I, ITEMP, J, K, MA, MKI, NFREE, NKI, PVT + DOUBLE PRECISION AII, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DGERQ2, DLARF, DLARFG, DORMR2, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04GD', -INFO ) + RETURN + END IF +C + K = MIN( M, N ) +C +C Move non-free rows bottom. +C + ITEMP = M + DO 10 I = M, 1, -1 + IF( JPVT( I ).NE.0 ) THEN + IF( I.NE.ITEMP ) THEN + CALL DSWAP( N, A( I, 1 ), LDA, A( ITEMP, 1 ), LDA ) + JPVT( I ) = JPVT( ITEMP ) + JPVT( ITEMP ) = I + ELSE + JPVT( I ) = I + END IF + ITEMP = ITEMP - 1 + ELSE + JPVT( I ) = I + END IF + 10 CONTINUE + NFREE = M - ITEMP +C +C Compute the RQ factorization and update remaining rows. +C + IF( NFREE.GT.0 ) THEN + MA = MIN( NFREE, N ) + CALL DGERQ2( MA, N, A(M-MA+1,1), LDA, TAU(K-MA+1), DWORK, + $ INFO ) + CALL DORMR2( 'Right', 'Transpose', M-MA, N, MA, A(M-MA+1,1), + $ LDA, TAU(K-MA+1), A, LDA, DWORK, INFO ) + END IF +C + IF( NFREE.LT.K ) THEN +C +C Initialize partial row norms. The first ITEMP elements of +C DWORK store the exact row norms. (Here, ITEMP is the number of +C free rows, which have been permuted to be the first ones.) +C + DO 20 I = 1, ITEMP + DWORK( I ) = DNRM2( N-NFREE, A( I, 1 ), LDA ) + DWORK( M+I ) = DWORK( I ) + 20 CONTINUE +C +C Compute factorization. +C + DO 40 I = K-NFREE, 1, -1 +C +C Determine ith pivot row and swap if necessary. +C + MKI = M - K + I + NKI = N - K + I + PVT = IDAMAX( MKI, DWORK, 1 ) +C + IF( PVT.NE.MKI ) THEN + CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( MKI ) + JPVT( MKI ) = ITEMP + DWORK( PVT ) = DWORK( MKI ) + DWORK( M+PVT ) = DWORK( M+MKI ) + END IF +C +C Generate elementary reflector H(i) to annihilate +C A(m-k+i,1:n-k+i-1), k = min(m,n). +C + CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) + $ ) +C +C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. +C + AII = A( MKI, NKI ) + A( MKI, NKI ) = ONE + CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, + $ TAU( I ), A, LDA, DWORK( 2*M+1 ) ) + A( MKI, NKI ) = AII +C +C Update partial row norms. +C + DO 30 J = 1, MKI - 1 + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - ( ABS( A( J, NKI ) ) / DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( M+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), LDA ) + DWORK( M+J ) = DWORK( J ) + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + 40 CONTINUE + END IF +C + RETURN +C *** Last line of MB04GD *** + END diff --git a/mex/sources/libslicot/MB04ID.f b/mex/sources/libslicot/MB04ID.f new file mode 100644 index 000000000..d28929f2f --- /dev/null +++ b/mex/sources/libslicot/MB04ID.f @@ -0,0 +1,278 @@ + SUBROUTINE MB04ID( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a QR factorization of an n-by-m matrix A (A = Q * R), +C having a p-by-min(p,m) zero triangle in the lower left-hand side +C corner, as shown below, for n = 8, m = 7, and p = 2: +C +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C A = [ x x x x x x x ], +C [ x x x x x x x ] +C [ 0 x x x x x x ] +C [ 0 0 x x x x x ] +C +C and optionally apply the transformations to an n-by-l matrix B +C (from the left). The problem structure is exploited. This +C computation is useful, for instance, in combined measurement and +C time update of one iteration of the time-invariant Kalman filter +C (square root information filter). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix A. M >= 0. +C +C P (input) INTEGER +C The order of the zero triagle. P >= 0. +C +C L (input) INTEGER +C The number of columns of the matrix B. L >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix A. The elements corresponding to the +C zero P-by-MIN(P,M) lower trapezoidal/triangular part +C (if P > 0) are not referenced. +C On exit, the elements on and above the diagonal of this +C array contain the MIN(N,M)-by-M upper trapezoidal matrix +C R (R is upper triangular, if N >= M) of the QR +C factorization, and the relevant elements below the +C diagonal contain the trailing components (the vectors v, +C see Method) of the elementary reflectors used in the +C factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,L) +C On entry, the leading N-by-L part of this array must +C contain the matrix B. +C On exit, the leading N-by-L part of this array contains +C the updated matrix B. +C If L = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N) if L > 0; +C LDB >= 1 if L = 0. +C +C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,M-1,M-P,L). +C For optimum performance LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses min(N,M) Householder transformations exploiting +C the zero pattern of the matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is an (N-P+I-2)-vector. The components of v are stored +C i i +C in the i-th column of A, beginning from the location i+1, and +C tau is stored in TAU(i). +C i +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009, +C Apr. 2009. +C +C KEYWORDS +C +C Elementary reflector, QR factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, NB, WRKOPT + DOUBLE PRECISION FIRST +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DGEQRF, DLARF, DLARFG, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LQUERY = ( LDWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN + INFO = -8 + ELSE + I = MAX( 1, M - 1, M - P, L ) + IF( LQUERY ) THEN + IF( M.GT.P ) THEN + NB = ILAENV( 1, 'DGEQRF', ' ', N-P, M-P, -1, -1 ) + WRKOPT = MAX( I, ( M - P )*NB ) + IF ( L.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LT', N-P, L, + $ MIN(N,M)-P, -1 ) ) + WRKOPT = MAX( WRKOPT, MAX( 1, L )*NB ) + END IF + END IF + ELSE IF( LDWORK.LT.I ) THEN + INFO = -11 + END IF + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04ID', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + ELSE IF( N.LE.P+1 ) THEN + DO 5 I = 1, MIN( N, M ) + TAU(I) = ZERO + 5 CONTINUE + DWORK(1) = ONE + RETURN + END IF +C +C Annihilate the subdiagonal elements of A and apply the +C transformations to B, if L > 0. +C Workspace: need MAX(M-1,L). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 10 I = 1, MIN( P, M ) +C +C Exploit the structure of the I-th column of A. +C + CALL DLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C + FIRST = A(I,I) + A(I,I) = ONE +C + IF ( I.LT.M ) CALL DLARF( 'Left', N-P, M-I, A(I,I), 1, + $ TAU(I), A(I,I+1), LDA, DWORK ) + IF ( L.GT.0 ) CALL DLARF( 'Left', N-P, L, A(I,I), 1, TAU(I), + $ B(I,1), LDB, DWORK ) +C + A(I,I) = FIRST + END IF + 10 CONTINUE +C + WRKOPT = MAX( 1, M - 1, L ) +C +C Fast QR factorization of the remaining right submatrix, if any. +C Workspace: need M-P; prefer (M-P)*NB. +C + IF( M.GT.P ) THEN + CALL DGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C + IF ( L.GT.0 ) THEN +C +C Apply the transformations to B. +C Workspace: need L; prefer L*NB. +C + CALL DORMQR( 'Left', 'Transpose', N-P, L, MIN(N,M)-P, + $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF + END IF +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of MB04ID *** + END diff --git a/mex/sources/libslicot/MB04IY.f b/mex/sources/libslicot/MB04IY.f new file mode 100644 index 000000000..4b07b2c35 --- /dev/null +++ b/mex/sources/libslicot/MB04IY.f @@ -0,0 +1,327 @@ + SUBROUTINE MB04IY( SIDE, TRANS, N, M, K, P, A, LDA, TAU, C, LDC, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To overwrite the real n-by-m matrix C with Q' * C, Q * C, +C C * Q', or C * Q, according to the following table +C +C SIDE = 'L' SIDE = 'R' +C TRANS = 'N': Q * C C * Q +C TRANS = 'T': Q'* C C * Q' +C +C where Q is a real orthogonal matrix defined as the product of +C k elementary reflectors +C +C Q = H(1) H(2) . . . H(k) +C +C as returned by SLICOT Library routine MB04ID. Q is of order n +C if SIDE = 'L' and of order m if SIDE = 'R'. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Specify if Q or Q' is applied from the left or right, +C as follows: +C = 'L': apply Q or Q' from the left; +C = 'R': apply Q or Q' from the right. +C +C TRANS CHARACTER*1 +C Specify if Q or Q' is to be applied, as follows: +C = 'N': apply Q (No transpose); +C = 'T': apply Q' (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix C. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix C. M >= 0. +C +C K (input) INTEGER +C The number of elementary reflectors whose product defines +C the matrix Q. +C N >= K >= 0, if SIDE = 'L'; +C M >= K >= 0, if SIDE = 'R'. +C +C P (input) INTEGER +C The order of the zero triagle (or the number of rows of +C the zero trapezoid) in the matrix triangularized by SLICOT +C Library routine MB04ID. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,K) +C On input, the elements in the rows i+1:min(n,n-p-1+i) of +C the i-th column, and TAU(i), represent the orthogonal +C reflector H(i), so that matrix Q is the product of +C elementary reflectors: Q = H(1) H(2) . . . H(k). +C A is modified by the routine but restored on exit. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= max(1,N), if SIDE = 'L'; +C LDA >= max(1,M), if SIDE = 'R'. +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C The scalar factors of the elementary reflectors. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix C. +C On exit, the leading N-by-M part of this array contains +C the updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,M), if SIDE = 'L'; +C LDWORK >= MAX(1,N), if SIDE = 'R'. +C For optimum performance LDWORK >= M*NB if SIDE = 'L', +C or LDWORK >= N*NB if SIDE = 'R', where NB is the optimal +C block size. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If SIDE = 'L', each elementary reflector H(i) modifies +C n-p elements of each column of C, for i = 1:p+1, and +C n-i+1 elements, for i = p+2:k. +C If SIDE = 'R', each elementary reflector H(i) modifies +C m-p elements of each row of C, for i = 1:p+1, and +C m-i+1 elements, for i = p+2:k. +C +C NUMERICAL ASPECTS +C +C The implemented method is numerically stable. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix operations, QR decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER INFO, K, LDA, LDC, LDWORK, M, N, P + CHARACTER SIDE, TRANS +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), TAU( * ) +C .. Local Scalars .. + LOGICAL LEFT, TRAN + INTEGER I + DOUBLE PRECISION AII, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C +C Check the scalar input arguments. +C + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + TRAN = LSAME( TRANS, 'T' ) +C + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. ( LEFT .AND. K.GT.N ) .OR. + $ ( .NOT.LEFT .AND. K.GT.M ) ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( ( LEFT .AND. LDA.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LEFT .AND. LDA.LT.MAX( 1, M ) ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( ( LEFT .AND. LDWORK.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LEFT .AND. LDWORK.LT.MAX( 1, N ) ) ) THEN + INFO = -13 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04IY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 .OR. ( LEFT .AND. N.LT.P ) + $ .OR. ( .NOT.LEFT .AND. M.LT.P ) ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF( LEFT ) THEN + WRKOPT = DBLE( M ) + IF( TRAN ) THEN +C + DO 10 I = 1, MIN( K, P ) +C +C Apply H(i) to C(i:i+n-p-1,1:m), from the left. +C Workspace: need M. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), + $ C( I, 1 ), LDC, DWORK ) + A( I, I ) = AII + 10 CONTINUE +C + IF ( P.LE.MIN( N, K ) ) THEN +C +C Apply H(i) to C, i = p+1:k, from the left. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + ELSE +C + IF ( P.LE.MIN( N, K ) ) THEN +C +C Apply H(i) to C, i = k:p+1:-1, from the left. +C Workspace: need M; prefer M*NB. +C + CALL DORMQR( SIDE, TRANS, N-P, M, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( P+1, 1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + DO 20 I = MIN( K, P ), 1, -1 +C +C Apply H(i) to C(i:i+n-p-1,1:m), from the left. +C Workspace: need M. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N-P, M, A( I, I ), 1, TAU( I ), + $ C( I, 1 ), LDC, DWORK ) + A( I, I ) = AII + 20 CONTINUE + END IF +C + ELSE +C + WRKOPT = DBLE( N ) + IF( TRAN ) THEN +C + IF ( P.LE.MIN( M, K ) ) THEN +C +C Apply H(i) to C, i = k:p+1:-1, from the right. +C Workspace: need N; prefer N*NB. +C + CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + DO 30 I = MIN( K, P ), 1, -1 +C +C Apply H(i) to C(1:n,i:i+m-p-1), from the right. +C Workspace: need N. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), + $ C( 1, I ), LDC, DWORK ) + A( I, I ) = AII + 30 CONTINUE +C + ELSE +C + DO 40 I = 1, MIN( K, P ) +C +C Apply H(i) to C(1:n,i:i+m-p-1), from the right. +C Workspace: need N. +C + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, N, M-P, A( I, I ), 1, TAU( I ), + $ C( 1, I ), LDC, DWORK ) + A( I, I ) = AII + 40 CONTINUE +C + IF ( P.LE.MIN( M, K ) ) THEN +C +C Apply H(i) to C, i = p+1:k, from the right. +C Workspace: need N; prefer N*NB. +C + CALL DORMQR( SIDE, TRANS, N, M-P, K-P, A( P+1, P+1 ), + $ LDA, TAU( P+1 ), C( 1, P+1 ), LDC, DWORK, + $ LDWORK, I ) + WRKOPT = MAX( WRKOPT, DWORK( 1 ) ) + END IF +C + END IF + END IF +C + DWORK( 1 ) = WRKOPT + RETURN +C +C *** Last line of MB04IY *** + END diff --git a/mex/sources/libslicot/MB04IZ.f b/mex/sources/libslicot/MB04IZ.f new file mode 100644 index 000000000..c9654a6a5 --- /dev/null +++ b/mex/sources/libslicot/MB04IZ.f @@ -0,0 +1,282 @@ + SUBROUTINE MB04IZ( N, M, P, L, A, LDA, B, LDB, TAU, ZWORK, LZWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a QR factorization of an n-by-m matrix A (A = Q * R), +C having a p-by-min(p,m) zero triangle in the lower left-hand side +C corner, as shown below, for n = 8, m = 7, and p = 2: +C +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C A = [ x x x x x x x ], +C [ x x x x x x x ] +C [ 0 x x x x x x ] +C [ 0 0 x x x x x ] +C +C and optionally apply the transformations to an n-by-l matrix B +C (from the left). The problem structure is exploited. This +C computation is useful, for instance, in combined measurement and +C time update of one iteration of the time-invariant Kalman filter +C (square root information filter). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix A. M >= 0. +C +C P (input) INTEGER +C The order of the zero triagle. P >= 0. +C +C L (input) INTEGER +C The number of columns of the matrix B. L >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix A. The elements corresponding to the +C zero P-by-MIN(P,M) lower trapezoidal/triangular part +C (if P > 0) are not referenced. +C On exit, the elements on and above the diagonal of this +C array contain the MIN(N,M)-by-M upper trapezoidal matrix +C R (R is upper triangular, if N >= M) of the QR +C factorization, and the relevant elements below the +C diagonal contain the trailing components (the vectors v, +C see Method) of the elementary reflectors used in the +C factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,L) +C On entry, the leading N-by-L part of this array must +C contain the matrix B. +C On exit, the leading N-by-L part of this array contains +C the updated matrix B. +C If L = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N) if L > 0; +C LDB >= 1 if L = 0. +C +C TAU (output) COMPLEX*16 array, dimension MIN(N,M) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK The length of the array ZWORK. +C LZWORK >= MAX(1,M-1,M-P,L). +C For optimum performance LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses min(N,M) Householder transformations exploiting +C the zero pattern of the matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is an (N-P+I-2)-vector. The components of v are stored +C i i +C in the i-th column of A, beginning from the location i+1, and +C tau is stored in TAU(i). +C i +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2009. +C +C KEYWORDS +C +C Elementary reflector, QR factorization, unitary transformation. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), + $ ONE = ( 1.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDB, LZWORK, M, N, P +C .. Array Arguments .. + COMPLEX*16 A(LDA,*), B(LDB,*), TAU(*), ZWORK(*) +C .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, NB, WRKOPT + COMPLEX*16 FIRST +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL XERBLA, ZGEQRF, ZLARF, ZLARFG, ZUNMQR +C .. Intrinsic Functions .. + INTRINSIC DCONJG, INT, MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + LQUERY = ( LZWORK.EQ.-1 ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.1 .OR. ( L.GT.0 .AND. LDB.LT.N ) ) THEN + INFO = -8 + ELSE + I = MAX( 1, M - 1, M - P, L ) + IF( LQUERY ) THEN + IF( M.GT.P ) THEN + NB = ILAENV( 1, 'ZGEQRF', ' ', N-P, M-P, -1, -1 ) + WRKOPT = MAX( I, ( M - P )*NB ) + IF ( L.GT.0 ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', N-P, L, + $ MIN(N,M)-P, -1 ) ) + WRKOPT = MAX( WRKOPT, MAX( 1, L )*NB ) + END IF + END IF + ELSE IF( LZWORK.LT.I ) THEN + INFO = -11 + END IF + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04IZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) THEN + ZWORK(1) = ONE + RETURN + ELSE IF( N.LE.P+1 ) THEN + DO 5 I = 1, MIN( N, M ) + TAU(I) = ZERO + 5 CONTINUE + ZWORK(1) = ONE + RETURN + END IF +C +C Annihilate the subdiagonal elements of A and apply the +C transformations to B, if L > 0. +C Workspace: need MAX(M-1,L). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of complex workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 10 I = 1, MIN( P, M ) +C +C Exploit the structure of the I-th column of A. +C + CALL ZLARFG( N-P, A(I,I), A(I+1,I), 1, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C + FIRST = A(I,I) + A(I,I) = ONE +C + IF ( I.LT.M ) CALL ZLARF( 'Left', N-P, M-I, A(I,I), 1, + $ DCONJG( TAU(I) ), A(I,I+1), LDA, + $ ZWORK ) + IF ( L.GT.0 ) CALL ZLARF( 'Left', N-P, L, A(I,I), 1, + $ DCONJG( TAU(I) ), B(I,1), LDB, + $ ZWORK ) +C + A(I,I) = FIRST + END IF + 10 CONTINUE +C + WRKOPT = MAX( 1, M - 1, L ) +C +C Fast QR factorization of the remaining right submatrix, if any. +C Workspace: need M-P; prefer (M-P)*NB. +C + IF( M.GT.P ) THEN + CALL ZGEQRF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), ZWORK, + $ LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) +C + IF ( L.GT.0 ) THEN +C +C Apply the transformations to B. +C Workspace: need L; prefer L*NB. +C + CALL ZUNMQR( 'Left', 'Conjugate', N-P, L, MIN(N,M)-P, + $ A(P+1,P+1), LDA, TAU(P+1), B(P+1,1), LDB, + $ ZWORK, LZWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) ) + END IF + END IF +C + ZWORK(1) = WRKOPT + RETURN +C *** Last line of MB04IZ *** + END diff --git a/mex/sources/libslicot/MB04JD.f b/mex/sources/libslicot/MB04JD.f new file mode 100644 index 000000000..8dc1a3b9b --- /dev/null +++ b/mex/sources/libslicot/MB04JD.f @@ -0,0 +1,248 @@ + SUBROUTINE MB04JD( N, M, P, L, A, LDA, B, LDB, TAU, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an LQ factorization of an n-by-m matrix A (A = L * Q), +C having a min(n,p)-by-p zero triangle in the upper right-hand side +C corner, as shown below, for n = 8, m = 7, and p = 2: +C +C [ x x x x x 0 0 ] +C [ x x x x x x 0 ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C A = [ x x x x x x x ], +C [ x x x x x x x ] +C [ x x x x x x x ] +C [ x x x x x x x ] +C +C and optionally apply the transformations to an l-by-m matrix B +C (from the right). The problem structure is exploited. This +C computation is useful, for instance, in combined measurement and +C time update of one iteration of the time-invariant Kalman filter +C (square root covariance filter). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of rows of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix A. M >= 0. +C +C P (input) INTEGER +C The order of the zero triagle. P >= 0. +C +C L (input) INTEGER +C The number of rows of the matrix B. L >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix A. The elements corresponding to the +C zero MIN(N,P)-by-P upper trapezoidal/triangular part +C (if P > 0) are not referenced. +C On exit, the elements on and below the diagonal of this +C array contain the N-by-MIN(N,M) lower trapezoidal matrix +C L (L is lower triangular, if N <= M) of the LQ +C factorization, and the relevant elements above the +C diagonal contain the trailing components (the vectors v, +C see Method) of the elementary reflectors used in the +C factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the matrix B. +C On exit, the leading L-by-M part of this array contains +C the updated matrix B. +C If L = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,L). +C +C TAU (output) DOUBLE PRECISION array, dimension MIN(N,M) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK The length of the array DWORK. +C LDWORK >= MAX(1,N-1,N-P,L). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine uses min(N,M) Householder transformations exploiting +C the zero pattern of the matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is an (M-P+I-2)-vector. The components of v are stored +C i i +C in the i-th row of A, beginning from the location i+1, and tau +C i +C is stored in TAU(i). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, LQ factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, LDB, LDWORK, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION FIRST, WRKOPT +C .. External Subroutines .. + EXTERNAL DGELQF, DLARF, DLARFG, DORMLQ, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MAX( 1, N - 1, N - P, L ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + ELSE IF( M.LE.P+1 ) THEN + DO 5 I = 1, MIN( N, M ) + TAU(I) = ZERO + 5 CONTINUE + DWORK(1) = ONE + RETURN + END IF +C +C Annihilate the superdiagonal elements of A and apply the +C transformations to B, if L > 0. +C Workspace: need MAX(N-1,L). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 10 I = 1, MIN( N, P ) +C +C Exploit the structure of the I-th row of A. +C + CALL DLARFG( M-P, A(I,I), A(I,I+1), LDA, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C + FIRST = A(I,I) + A(I,I) = ONE +C + IF ( I.LT.N ) CALL DLARF( 'Right', N-I, M-P, A(I,I), LDA, + $ TAU(I), A(I+1,I), LDA, DWORK ) + IF ( L.GT.0 ) CALL DLARF( 'Right', L, M-P, A(I,I), LDA, + $ TAU(I), B(1,I), LDB, DWORK ) +C + A(I,I) = FIRST + END IF + 10 CONTINUE +C + WRKOPT = MAX( ONE, DBLE( N - 1 ), DBLE( L ) ) +C +C Fast LQ factorization of the remaining trailing submatrix, if any. +C Workspace: need N-P; prefer (N-P)*NB. +C + IF( N.GT.P ) THEN + CALL DGELQF( N-P, M-P, A(P+1,P+1), LDA, TAU(P+1), DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF ( L.GT.0 ) THEN +C +C Apply the transformations to B. +C Workspace: need L; prefer L*NB. +C + CALL DORMLQ( 'Right', 'Transpose', L, M-P, MIN(N,M)-P, + $ A(P+1,P+1), LDA, TAU(P+1), B(1,P+1), LDB, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of MB04JD *** + END diff --git a/mex/sources/libslicot/MB04KD.f b/mex/sources/libslicot/MB04KD.f new file mode 100644 index 000000000..adcdcb6f9 --- /dev/null +++ b/mex/sources/libslicot/MB04KD.f @@ -0,0 +1,209 @@ + SUBROUTINE MB04KD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a QR factorization of the first block column and +C apply the orthogonal transformations (from the left) also to the +C second block column of a structured matrix, as follows +C _ +C [ R 0 ] [ R C ] +C Q' * [ ] = [ ] +C [ A B ] [ 0 D ] +C _ +C where R and R are upper triangular. The matrix A can be full or +C upper trapezoidal/triangular. The problem structure is exploited. +C This computation is useful, for instance, in combined measurement +C and time update of one iteration of the Kalman filter (square +C root information filter). +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'U': Matrix A is upper trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices R and R. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B, C and D. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices A, B and D. P >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C _ +C array contains the upper triangular matrix R. +C The strict lower triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if UPLO = 'F', the leading P-by-N part of this +C array must contain the matrix A. If UPLO = 'U', the +C leading MIN(P,N)-by-N part of this array must contain the +C upper trapezoidal (upper triangular if P >= N) matrix A, +C and the elements below the diagonal are not referenced. +C On exit, the leading P-by-N part (upper trapezoidal or +C triangular, if UPLO = 'U') of this array contains the +C trailing components (the vectors v, see Method) of the +C elementary reflectors used in the factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,P). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading P-by-M part of this array must +C contain the matrix B. +C On exit, the leading P-by-M part of this array contains +C the computed matrix D. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,P). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array contains the +C computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is a P-vector, if UPLO = 'F', or an min(i,P)-vector, if +C i +C UPLO = 'U'. The components of v are stored in the i-th column +C i +C of A, and tau is stored in TAU(i). +C i +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, QR factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IM = P +C + DO 10 I = 1, N +C +C Annihilate the I-th column of A and apply the transformations +C to the entire block matrix, exploiting its structure. +C + IF( LUPLO ) IM = MIN( I, P ) + CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C +C [ R(I,I+1:N) 0 ] +C [ w C(I,:) ] := [ 1 v' ] * [ ] +C [ A(1:IM,I+1:N) B(1:IM,:) ] +C + IF( I.LT.N ) THEN + CALL DCOPY( N-I, R(I,I+1), LDR, DWORK, 1 ) + CALL DGEMV( 'Transpose', IM, N-I, ONE, A(1,I+1), LDA, + $ A(1,I), 1, ONE, DWORK, 1 ) + END IF + CALL DGEMV( 'Transpose', IM, M, ONE, B, LDB, A(1,I), 1, + $ ZERO, C(I,1), LDC ) +C +C [ R(I,I+1:N) C(I,:) ] [ R(I,I+1:N) 0 ] +C [ ] := [ ] +C [ A(1:IM,I+1:N) D(1:IM,:) ] [ A(1:IM,I+1:N) B(1:IM,:) ] +C +C [ 1 ] +C - tau * [ ] * [ w C(I,:) ] +C [ v ] +C + IF( I.LT.N ) THEN + CALL DAXPY( N-I, -TAU(I), DWORK, 1, R(I,I+1), LDR ) + CALL DGER( IM, N-I, -TAU(I), A(1,I), 1, DWORK, 1, + $ A(1,I+1), LDA ) + END IF + CALL DSCAL( M, -TAU(I), C(I,1), LDC ) + CALL DGER( IM, M, ONE, A(1,I), 1, C(I,1), LDC, B, LDB ) + END IF + 10 CONTINUE +C + RETURN +C *** Last line of MB04KD *** + END diff --git a/mex/sources/libslicot/MB04LD.f b/mex/sources/libslicot/MB04LD.f new file mode 100644 index 000000000..7931437f5 --- /dev/null +++ b/mex/sources/libslicot/MB04LD.f @@ -0,0 +1,209 @@ + SUBROUTINE MB04LD( UPLO, N, M, P, L, LDL, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate an LQ factorization of the first block row and apply +C the orthogonal transformations (from the right) also to the second +C block row of a structured matrix, as follows +C _ +C [ L A ] [ L 0 ] +C [ ]*Q = [ ] +C [ 0 B ] [ C D ] +C _ +C where L and L are lower triangular. The matrix A can be full or +C lower trapezoidal/triangular. The problem structure is exploited. +C This computation is useful, for instance, in combined measurement +C and time update of one iteration of the Kalman filter (square +C root covariance filter). +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'L': Matrix A is lower trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices L and L. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices A, B and D. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices B, C and D. P >= 0. +C +C L (input/output) DOUBLE PRECISION array, dimension (LDL,N) +C On entry, the leading N-by-N lower triangular part of this +C array must contain the lower triangular matrix L. +C On exit, the leading N-by-N lower triangular part of this +C _ +C array contains the lower triangular matrix L. +C The strict upper triangular part of this array is not +C referenced. +C +C LDL INTEGER +C The leading dimension of array L. LDL >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, if UPLO = 'F', the leading N-by-M part of this +C array must contain the matrix A. If UPLO = 'L', the +C leading N-by-MIN(N,M) part of this array must contain the +C lower trapezoidal (lower triangular if N <= M) matrix A, +C and the elements above the diagonal are not referenced. +C On exit, the leading N-by-M part (lower trapezoidal or +C triangular, if UPLO = 'L') of this array contains the +C trailing components (the vectors v, see Method) of the +C elementary reflectors used in the factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading P-by-M part of this array must +C contain the matrix B. +C On exit, the leading P-by-M part of this array contains +C the computed matrix D. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,P). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array contains the +C computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ), +C H = I - tau *u *u', u = ( v ) +C i i i i i ( i) +C +C where v is an M-vector, if UPLO = 'F', or an min(i,M)-vector, if +C i +C UPLO = 'L'. The components of v are stored in the i-th row of A, +C i +C and tau is stored in TAU(i). +C i +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, LQ factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDL, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ L(LDL,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, DSCAL +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C + IF( MIN( M, N ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'L' ) + IM = M +C + DO 10 I = 1, N +C +C Annihilate the I-th row of A and apply the transformations to +C the entire block matrix, exploiting its structure. +C + IF( LUPLO ) IM = MIN( I, M ) + CALL DLARFG( IM+1, L(I,I), A(I,1), LDA, TAU(I) ) + IF( TAU(I).NE.ZERO ) THEN +C +C [ w ] [ L(I+1:N,I) A(I+1:N,1:IM) ] [ 1 ] +C [ ] := [ ] * [ ] +C [ C(:,I) ] [ 0 B(:,1:IM) ] [ v ] +C + IF( I.LT.N ) THEN + CALL DCOPY( N-I, L(I+1,I), 1, DWORK, 1 ) + CALL DGEMV( 'No transpose', N-I, IM, ONE, A(I+1,1), LDA, + $ A(I,1), LDA, ONE, DWORK, 1 ) + END IF + CALL DGEMV( 'No transpose', P, IM, ONE, B, LDB, A(I,1), + $ LDA, ZERO, C(1,I), 1 ) +C +C [ L(I+1:N,I) A(I+1:N,1:IM) ] [ L(I+1:N,I) A(I+1:N,1:IM) ] +C [ ] := [ ] +C [ C(:,I) D(:,1:IM) ] [ 0 B(:,1:IM) ] +C +C [ w ] +C - tau * [ ] * [ 1 , v'] +C [ C(:,I) ] +C + IF( I.LT.N ) THEN + CALL DAXPY( N-I, -TAU(I), DWORK, 1, L(I+1,I), 1 ) + CALL DGER( N-I, IM, -TAU(I), DWORK, 1, A(I,1), LDA, + $ A(I+1,1), LDA ) + END IF + CALL DSCAL( P, -TAU(I), C(1,I), 1 ) + CALL DGER( P, IM, ONE, C(1,I), 1, A(I,1), LDA, B, LDB ) + END IF + 10 CONTINUE +C + RETURN +C *** Last line of MB04LD *** + END diff --git a/mex/sources/libslicot/MB04MD.f b/mex/sources/libslicot/MB04MD.f new file mode 100644 index 000000000..8a9055af2 --- /dev/null +++ b/mex/sources/libslicot/MB04MD.f @@ -0,0 +1,290 @@ + SUBROUTINE MB04MD( N, MAXRED, A, LDA, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the 1-norm of a general real matrix A by balancing. +C This involves diagonal similarity transformations applied +C iteratively to A to make the rows and columns as close in norm as +C possible. +C +C This routine can be used instead LAPACK Library routine DGEBAL, +C when no reduction of the 1-norm of the matrix is possible with +C DGEBAL, as for upper triangular matrices. LAPACK Library routine +C DGEBAK, with parameters ILO = 1, IHI = N, and JOB = 'S', should +C be used to apply the backward transformation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C MAXRED (input/output) DOUBLE PRECISION +C On entry, the maximum allowed reduction in the 1-norm of +C A (in an iteration) if zero rows or columns are +C encountered. +C If MAXRED > 0.0, MAXRED must be larger than one (to enable +C the norm reduction). +C If MAXRED <= 0.0, then the value 10.0 for MAXRED is +C used. +C On exit, if the 1-norm of the given matrix A is non-zero, +C the ratio between the 1-norm of the given matrix and the +C 1-norm of the balanced matrix. Usually, this ratio will be +C larger than one, but it can sometimes be one, or even less +C than one (for instance, for some companion matrices). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the input matrix A. +C On exit, the leading N-by-N part of this array contains +C the balanced matrix. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C SCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to A. If D(j) is the scaling +C factor applied to row and column j, then SCALE(j) = D(j), +C for j = 1,...,N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation inv(D) * A * D to make the 1-norms of each row +C of A and its corresponding column nearly equal. +C +C Information about the diagonal matrix D is returned in the vector +C SCALE. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB04AD by T.W.C. Williams, +C Kingston Polytechnic, United Kingdom, October 1984. +C This subroutine is based on LAPACK routine DGEBAL, and routine +C BALABC (A. Varga, German Aerospace Research Establishment, DLR). +C +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 1.0D+1 ) + DOUBLE PRECISION FACTOR, MAXR + PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION MAXRED +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), SCALE( * ) +C .. +C .. Local Scalars .. + LOGICAL NOCONV + INTEGER I, ICA, IRA, J + DOUBLE PRECISION ANORM, C, CA, F, G, MAXNRM, R, RA, S, SFMAX1, + $ SFMAX2, SFMIN1, SFMIN2, SRED +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04MD', -INFO ) + RETURN + END IF +C + IF( N.EQ.0 ) + $ RETURN +C + DO 10 I = 1, N + SCALE( I ) = ONE + 10 CONTINUE +C +C Compute the 1-norm of matrix A and exit if it is zero. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, SCALE ) + IF( ANORM.EQ.ZERO ) + $ RETURN +C +C Set some machine parameters and the maximum reduction in the +C 1-norm of A if zero rows or columns are encountered. +C + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C + SRED = MAXRED + IF( SRED.LE.ZERO ) SRED = MAXR +C + MAXNRM = MAX( ANORM/SRED, SFMIN1 ) +C +C Balance the matrix. +C +C Iterative loop for norm reduction. +C + 20 CONTINUE + NOCONV = .FALSE. +C + DO 80 I = 1, N + C = ZERO + R = ZERO +C + DO 30 J = 1, N + IF( J.EQ.I ) + $ GO TO 30 + C = C + ABS( A( J, I ) ) + R = R + ABS( A( I, J ) ) + 30 CONTINUE + ICA = IDAMAX( N, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IDAMAX( N, A( I, 1 ), LDA ) + RA = ABS( A( I, IRA ) ) +C +C Special case of zero C and/or R. +C + IF( C.EQ.ZERO .AND. R.EQ.ZERO ) + $ GO TO 80 + IF( C.EQ.ZERO ) THEN + IF( R.LE.MAXNRM) + $ GO TO 80 + C = MAXNRM + END IF + IF( R.EQ.ZERO ) THEN + IF( C.LE.MAXNRM ) + $ GO TO 80 + R = MAXNRM + END IF +C +C Guard against zero C or R due to underflow. +C + G = R / SCLFAC + F = ONE + S = C + R + 40 CONTINUE + IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR. + $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 50 + F = F*SCLFAC + C = C*SCLFAC + CA = CA*SCLFAC + R = R / SCLFAC + G = G / SCLFAC + RA = RA / SCLFAC + GO TO 40 +C + 50 CONTINUE + G = C / SCLFAC + 60 CONTINUE + IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR. + $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 70 + F = F / SCLFAC + C = C / SCLFAC + G = G / SCLFAC + CA = CA / SCLFAC + R = R*SCLFAC + RA = RA*SCLFAC + GO TO 60 +C +C Now balance. +C + 70 CONTINUE + IF( ( C+R ).GE.FACTOR*S ) + $ GO TO 80 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 80 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 80 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +C + CALL DSCAL( N, G, A( I, 1 ), LDA ) + CALL DSCAL( N, F, A( 1, I ), 1 ) +C + 80 CONTINUE +C + IF( NOCONV ) + $ GO TO 20 +C +C Set the norm reduction parameter. +C + MAXRED = ANORM/DLANGE( '1-norm', N, N, A, LDA, SCALE ) +C + RETURN +C *** End of MB04MD *** + END diff --git a/mex/sources/libslicot/MB04ND.f b/mex/sources/libslicot/MB04ND.f new file mode 100644 index 000000000..2a7e0725e --- /dev/null +++ b/mex/sources/libslicot/MB04ND.f @@ -0,0 +1,257 @@ + SUBROUTINE MB04ND( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate an RQ factorization of the first block row and +C apply the orthogonal transformations (from the right) also to the +C second block row of a structured matrix, as follows +C _ +C [ A R ] [ 0 R ] +C [ ] * Q' = [ _ _ ] +C [ C B ] [ C B ] +C _ +C where R and R are upper triangular. The matrix A can be full or +C upper trapezoidal/triangular. The problem structure is exploited. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'U': Matrix A is upper trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices R and R. N >= 0. +C +C M (input) INTEGER +C The number of rows of the matrices B and C. M >= 0. +C +C P (input) INTEGER +C The number of columns of the matrices A and C. P >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C _ +C array contains the upper triangular matrix R. +C The strict lower triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,P) +C On entry, if UPLO = 'F', the leading N-by-P part of this +C array must contain the matrix A. For UPLO = 'U', if +C N <= P, the upper triangle of the subarray A(1:N,P-N+1:P) +C must contain the N-by-N upper triangular matrix A, and if +C N >= P, the elements on and above the (N-P)-th subdiagonal +C must contain the N-by-P upper trapezoidal matrix A. +C On exit, if UPLO = 'F', the leading N-by-P part of this +C array contains the trailing components (the vectors v, see +C METHOD) of the elementary reflectors used in the +C factorization. If UPLO = 'U', the upper triangle of the +C subarray A(1:N,P-N+1:P) (if N <= P), or the elements on +C and above the (N-P)-th subdiagonal (if N >= P), contain +C the trailing components (the vectors v, see METHOD) of the +C elementary reflectors used in the factorization. +C The remaining elements are not referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C _ +C the computed matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) +C On entry, the leading M-by-P part of this array must +C contain the matrix C. +C On exit, the leading M-by-P part of this array contains +C _ +C the computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ) +C H = I - tau *u *u', u = ( v ), +C i i i i i ( i) +C +C where v is a P-vector, if UPLO = 'F', or a min(N-i+1,P)-vector, +C i +C if UPLO = 'U'. The components of v are stored in the i-th row +C i +C of A, and tau is stored in TAU(i), i = N,N-1,...,1. +C i +C In-line code for applying Householder transformations is used +C whenever possible (see MB04NY routine). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary reflector, RQ factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM, IP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, MB04NY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IF ( LUPLO ) THEN +C + DO 10 I = N, 1, -1 +C +C Annihilate the I-th row of A and apply the transformations +C to the entire block matrix, exploiting its structure. +C + IM = MIN( N-I+1, P ) + IP = MAX( P-N+I, 1 ) + CALL DLARFG( IM+1, R(I,I), A(I,IP), LDA, TAU(I) ) +C +C Compute +C [ 1 ] +C w := [ R(1:I-1,I) A(1:I-1,IP:P) ] * [ ], +C [ v ] +C +C [ R(1:I-1,I) A(1:I-1,IP:P) ] = +C [ R(1:I-1,I) A(1:I-1,IP:P) ] - tau * w * [ 1 v' ]. +C + IF ( I.GT.0 ) +C + $ CALL MB04NY( I-1, IM, A(I,IP), LDA, TAU(I), R(1,I), LDR, + $ A(1,IP), LDA, DWORK ) +C +C Compute +C [ 1 ] +C w := [ B(:,I) C(:,IP:P) ] * [ ], +C [ v ] +C +C [ B(:,I) C(:,IP:P) ] = [ B(:,I) C(:,IP:P) ] - +C tau * w * [ 1 v' ]. +C + IF ( M.GT.0 ) + $ CALL MB04NY( M, IM, A(I,IP), LDA, TAU(I), B(1,I), LDB, + $ C(1,IP), LDC, DWORK ) + 10 CONTINUE +C + ELSE +C + DO 20 I = N, 2 , -1 +C +C Annihilate the I-th row of A and apply the transformations +C to the first block row, exploiting its structure. +C + CALL DLARFG( P+1, R(I,I), A(I,1), LDA, TAU(I) ) +C +C Compute +C [ 1 ] +C w := [ R(1:I-1,I) A(1:I-1,:) ] * [ ], +C [ v ] +C +C [ R(1:I-1,I) A(1:I-1,:) ] = [ R(1:I-1,I) A(1:I-1,:) ] - +C tau * w * [ 1 v' ]. +C + CALL MB04NY( I-1, P, A(I,1), LDA, TAU(I), R(1,I), LDR, A, + $ LDA, DWORK ) + 20 CONTINUE +C + CALL DLARFG( P+1, R(1,1), A(1,1), LDA, TAU(1) ) + IF ( M.GT.0 ) THEN +C +C Apply the transformations to the second block row. +C + DO 30 I = N, 1, -1 +C +C Compute +C [ 1 ] +C w := [ B(:,I) C ] * [ ], +C [ v ] +C +C [ B(:,I) C ] = [ B(:,I) C ] - tau * w * [ 1 v' ]. +C + CALL MB04NY( M, P, A(I,1), LDA, TAU(I), B(1,I), LDB, C, + $ LDC, DWORK ) + 30 CONTINUE +C + END IF + END IF + RETURN +C *** Last line of MB04ND *** + END diff --git a/mex/sources/libslicot/MB04NY.f b/mex/sources/libslicot/MB04NY.f new file mode 100644 index 000000000..4e884454c --- /dev/null +++ b/mex/sources/libslicot/MB04NY.f @@ -0,0 +1,437 @@ + SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a real elementary reflector H to a real m-by-(n+1) +C matrix C = [ A B ], from the right, where A has one column. H is +C represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real n-vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices A and B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix B. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (1+(N-1)*ABS( INCV )) +C The vector v in the representation of H. +C +C INCV (input) INTEGER +C The increment between the elements of v. INCV <> 0. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,1) +C On entry, the leading M-by-1 part of this array must +C contain the matrix A. +C On exit, the leading M-by-1 part of this array contains +C the updated matrix A (the first column of C * H). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C the updated matrix B (the last n columns of C * H). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (M) +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking the special +C structure of C into account. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C Based on LAPACK routines DLARFX and DLATZM. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INCV, LDA, LDB, M, N + DOUBLE PRECISION TAU +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) +C .. Local Scalars .. + INTEGER IV, J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, + $ V3, V4, V5, V6, V7, V8, V9 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN +C +C Form C * H, where H has order n+1. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) N+1 +C +C Code for general N. Compute +C +C w := C*u, C := C - tau * w * u'. +C + CALL DCOPY( M, A, 1, DWORK, 1 ) + CALL DGEMV( 'No transpose', M, N, ONE, B, LDB, V, INCV, ONE, + $ DWORK, 1 ) + CALL DAXPY( M, -TAU, DWORK, 1, A, 1 ) + CALL DGER( M, N, -TAU, DWORK, 1, V, INCV, B, LDB ) + GO TO 210 + 10 CONTINUE +C +C Special code for 1 x 1 Householder +C + T1 = ONE - TAU + DO 20 J = 1, M + A( J, 1 ) = T1*A( J, 1 ) + 20 CONTINUE + GO TO 210 + 30 CONTINUE +C +C Special code for 2 x 2 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + DO 40 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + 40 CONTINUE + GO TO 210 + 50 CONTINUE +C +C Special code for 3 x 3 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + DO 60 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + 60 CONTINUE + GO TO 210 + 70 CONTINUE +C +C Special code for 4 x 4 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + DO 80 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + 80 CONTINUE + GO TO 210 + 90 CONTINUE +C +C Special code for 5 x 5 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + DO 100 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + 100 CONTINUE + GO TO 210 + 110 CONTINUE +C +C Special code for 6 x 6 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + DO 120 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + 120 CONTINUE + GO TO 210 + 130 CONTINUE +C +C Special code for 7 x 7 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + DO 140 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + 140 CONTINUE + GO TO 210 + 150 CONTINUE +C +C Special code for 8 x 8 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + DO 160 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + 160 CONTINUE + GO TO 210 + 170 CONTINUE +C +C Special code for 9 x 9 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + IV = IV + INCV + V8 = V( IV ) + T8 = TAU*V8 + DO 180 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + V8*B( J, 8 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + B( J, 8 ) = B( J, 8 ) - SUM*T8 + 180 CONTINUE + GO TO 210 + 190 CONTINUE +C +C Special code for 10 x 10 Householder +C + IV = 1 + IF( INCV.LT.0 ) + $ IV = (-N+1)*INCV + 1 + V1 = V( IV ) + T1 = TAU*V1 + IV = IV + INCV + V2 = V( IV ) + T2 = TAU*V2 + IV = IV + INCV + V3 = V( IV ) + T3 = TAU*V3 + IV = IV + INCV + V4 = V( IV ) + T4 = TAU*V4 + IV = IV + INCV + V5 = V( IV ) + T5 = TAU*V5 + IV = IV + INCV + V6 = V( IV ) + T6 = TAU*V6 + IV = IV + INCV + V7 = V( IV ) + T7 = TAU*V7 + IV = IV + INCV + V8 = V( IV ) + T8 = TAU*V8 + IV = IV + INCV + V9 = V( IV ) + T9 = TAU*V9 + DO 200 J = 1, M + SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) + + $ V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) + + $ V7*B( J, 7 ) + V8*B( J, 8 ) + V9*B( J, 9 ) + A( J, 1 ) = A( J, 1 ) - SUM*TAU + B( J, 1 ) = B( J, 1 ) - SUM*T1 + B( J, 2 ) = B( J, 2 ) - SUM*T2 + B( J, 3 ) = B( J, 3 ) - SUM*T3 + B( J, 4 ) = B( J, 4 ) - SUM*T4 + B( J, 5 ) = B( J, 5 ) - SUM*T5 + B( J, 6 ) = B( J, 6 ) - SUM*T6 + B( J, 7 ) = B( J, 7 ) - SUM*T7 + B( J, 8 ) = B( J, 8 ) - SUM*T8 + B( J, 9 ) = B( J, 9 ) - SUM*T9 + 200 CONTINUE + 210 CONTINUE + RETURN +C *** Last line of MB04NY *** + END diff --git a/mex/sources/libslicot/MB04OD.f b/mex/sources/libslicot/MB04OD.f new file mode 100644 index 000000000..694c81d75 --- /dev/null +++ b/mex/sources/libslicot/MB04OD.f @@ -0,0 +1,257 @@ + SUBROUTINE MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC, + $ TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate a QR factorization of the first block column and +C apply the orthogonal transformations (from the left) also to the +C second block column of a structured matrix, as follows +C _ _ +C [ R B ] [ R B ] +C Q' * [ ] = [ _ ] +C [ A C ] [ 0 C ] +C _ +C where R and R are upper triangular. The matrix A can be full or +C upper trapezoidal/triangular. The problem structure is exploited. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates if the matrix A is or not triangular as follows: +C = 'U': Matrix A is upper trapezoidal/triangular; +C = 'F': Matrix A is full. +C +C Input/Output Parameters +C +C N (input) INTEGER _ +C The order of the matrices R and R. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrices B and C. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrices A and C. P >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C _ +C array contains the upper triangular matrix R. +C The strict lower triangular part of this array is not +C referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if UPLO = 'F', the leading P-by-N part of this +C array must contain the matrix A. If UPLO = 'U', the +C leading MIN(P,N)-by-N part of this array must contain the +C upper trapezoidal (upper triangular if P >= N) matrix A, +C and the elements below the diagonal are not referenced. +C On exit, the leading P-by-N part (upper trapezoidal or +C triangular, if UPLO = 'U') of this array contains the +C trailing components (the vectors v, see Method) of the +C elementary reflectors used in the factorization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,P). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix B. +C On exit, the leading N-by-M part of this array contains +C _ +C the computed matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading P-by-M part of this array must +C contain the matrix C. +C On exit, the leading P-by-M part of this array contains +C _ +C the computed matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The scalar factors of the elementary reflectors used. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N-1,M)) +C +C METHOD +C +C The routine uses N Householder transformations exploiting the zero +C pattern of the block matrix. A Householder matrix has the form +C +C ( 1 ) +C H = I - tau *u *u', u = ( v ), +C i i i i i ( i) +C +C where v is a P-vector, if UPLO = 'F', or a min(i,P)-vector, if +C i +C UPLO = 'U'. The components of v are stored in the i-th column +C i +C of A, and tau is stored in TAU(i). +C i +C In-line code for applying Householder transformations is used +C whenever possible (see MB04OY routine). +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Elementary reflector, QR factorization, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDC, LDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ R(LDR,*), TAU(*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, MB04OY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IF( MIN( N, P ).EQ.0 ) + $ RETURN +C + LUPLO = LSAME( UPLO, 'U' ) + IF ( LUPLO ) THEN +C + DO 10 I = 1, N +C +C Annihilate the I-th column of A and apply the +C transformations to the entire block matrix, exploiting +C its structure. +C + IM = MIN( I, P ) + CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) ) +C +C Compute +C [ R(I,I+1:N) ] +C w := [ 1 v' ] * [ ], +C [ A(1:IM,I+1:N) ] +C +C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w . +C [ A(1:IM,I+1:N) ] [ A(1:IM,I+1:N) ] [ v ] +C + IF ( N-I.GT.0 ) + $ CALL MB04OY( IM, N-I, A(1,I), TAU(I), R(I,I+1), LDR, + $ A(1,I+1), LDA, DWORK ) +C +C Compute +C [ B(I,:) ] +C w := [ 1 v' ] * [ ], +C [ C(1:IM,:) ] +C +C [ B(I,:) ] [ B(I,:) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w. +C [ C(1:IM,:) ] [ C(1:IM,:) ] [ v ] +C +C + IF ( M.GT.0 ) + $ CALL MB04OY( IM, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, + $ DWORK ) + 10 CONTINUE +C + ELSE +C + DO 20 I = 1, N - 1 +C +C Annihilate the I-th column of A and apply the +C transformations to the first block column, exploiting its +C structure. +C + CALL DLARFG( P+1, R(I,I), A(1,I), 1, TAU(I) ) +C +C Compute +C [ R(I,I+1:N) ] +C w := [ 1 v' ] * [ ], +C [ A(:,I+1:N) ] +C +C [ R(I,I+1:N) ] [ R(I,I+1:N) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w . +C [ A(:,I+1:N) ] [ A(:,I+1:N) ] [ v ] +C + CALL MB04OY( P, N-I, A(1,I), TAU(I), R(I,I+1), LDR, + $ A(1,I+1), LDA, DWORK ) + 20 CONTINUE +C + CALL DLARFG( P+1, R(N,N), A(1,N), 1, TAU(N) ) + IF ( M.GT.0 ) THEN +C +C Apply the transformations to the second block column. +C + DO 30 I = 1, N +C +C Compute +C [ B(I,:) ] +C w := [ 1 v' ] * [ ], +C [ C ] +C +C [ B(I,:) ] [ B(I,:) ] [ 1 ] +C [ ] := [ ] - tau * [ ] * w. +C [ C ] [ C ] [ v ] +C + CALL MB04OY( P, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC, + $ DWORK ) + 30 CONTINUE +C + END IF + END IF + RETURN +C *** Last line of MB04OD *** + END diff --git a/mex/sources/libslicot/MB04OW.f b/mex/sources/libslicot/MB04OW.f new file mode 100644 index 000000000..ab5940943 --- /dev/null +++ b/mex/sources/libslicot/MB04OW.f @@ -0,0 +1,251 @@ + SUBROUTINE MB04OW( M, N, P, A, LDA, T, LDT, X, INCX, B, LDB, + $ C, LDC, D, INCD ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the QR factorization +C +C ( U ) = Q*( R ), where U = ( U1 U2 ), R = ( R1 R2 ), +C ( x' ) ( 0 ) ( 0 T ) ( 0 R3 ) +C +C where U and R are (m+n)-by-(m+n) upper triangular matrices, x is +C an m+n element vector, U1 is m-by-m, T is n-by-n, stored +C separately, and Q is an (m+n+1)-by-(m+n+1) orthogonal matrix. +C +C The matrix ( U1 U2 ) must be supplied in the m-by-(m+n) upper +C trapezoidal part of the array A and this is overwritten by the +C corresponding part ( R1 R2 ) of R. The remaining upper triangular +C part of R, R3, is overwritten on the array T. +C +C The transformations performed are also applied to the (m+n+1)-by-p +C matrix ( B' C' d )' (' denotes transposition), where B, C, and d' +C are m-by-p, n-by-p, and 1-by-p matrices, respectively. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix ( U1 U2 ). M >= 0. +C +C N (input) INTEGER +C The order of the matrix T. N >= 0. +C +C P (input) INTEGER +C The number of columns of the matrices B and C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-(M+N) upper trapezoidal part of +C this array must contain the upper trapezoidal matrix +C ( U1 U2 ). +C On exit, the leading M-by-(M+N) upper trapezoidal part of +C this array contains the upper trapezoidal matrix ( R1 R2 ). +C The strict lower triangle of A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C T (input/output) DOUBLE PRECISION array, dimension (LDT,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix T. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular matrix R3. +C The strict lower triangle of T is not referenced. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= max(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(M+N-1)*INCX), if M+N > 0, or dimension (0), if M+N = 0. +C On entry, the incremented array X must contain the +C vector x. On exit, the content of X is changed. +C +C INCX (input) INTEGER +C Specifies the increment for the elements of X. INCX > 0. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,P) +C On entry, the leading M-by-P part of this array must +C contain the matrix B. +C On exit, the leading M-by-P part of this array contains +C the transformed matrix B. +C If M = 0 or P = 0, this array is not referenced. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= max(1,M), if P > 0; +C LDB >= 1, if P = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,P) +C On entry, the leading N-by-P part of this array must +C contain the matrix C. +C On exit, the leading N-by-P part of this array contains +C the transformed matrix C. +C If N = 0 or P = 0, this array is not referenced. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= max(1,N), if P > 0; +C LDC >= 1, if P = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (1+(P-1)*INCD), if P > 0, or dimension (0), if P = 0. +C On entry, the incremented array D must contain the +C vector d. +C On exit, this incremented array contains the transformed +C vector d. +C If P = 0, this array is not referenced. +C +C INCD (input) INTEGER +C Specifies the increment for the elements of D. INCD > 0. +C +C METHOD +C +C Let q = m+n. The matrix Q is formed as a sequence of plane +C rotations in planes (1, q+1), (2, q+1), ..., (q, q+1), the +C rotation in the (j, q+1)th plane, Q(j), being chosen to +C annihilate the jth element of x. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0((M+N)*(M+N+P)) operations and is backward +C stable. +C +C FURTHER COMMENTS +C +C For P = 0, this routine produces the same result as SLICOT Library +C routine MB04OX, but matrix T may not be stored in the array A. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INCD, INCX, LDA, LDB, LDC, LDT, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*), T(LDT,*), + $ X(*) +C .. Local Scalars .. + DOUBLE PRECISION CI, SI, TEMP + INTEGER I, IX, MN +C .. External Subroutines .. + EXTERNAL DLARTG, DROT +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + MN = M + N + IF ( INCX.GT.1 ) THEN +C +C Code for increment INCX > 1. +C + IX = 1 + IF ( M.GT.0 ) THEN +C + DO 10 I = 1, M - 1 + CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) + A(I,I) = TEMP + IX = IX + INCX + CALL DROT( MN-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) + 10 CONTINUE +C + CALL DLARTG( A(M,M), X(IX), CI, SI, TEMP ) + A(M,M) = TEMP + IX = IX + INCX + IF ( N.GT.0 ) + $ CALL DROT( N, A(M,M+1), LDA, X(IX), INCX, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) + END IF +C + IF ( N.GT.0 ) THEN +C + DO 20 I = 1, N - 1 + CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) + T(I,I) = TEMP + IX = IX + INCX + CALL DROT( N-I, T(I,I+1), LDT, X(IX), INCX, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) + 20 CONTINUE +C + CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) + T(N,N) = TEMP + IF ( P.GT.0 ) + $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) + END IF +C + ELSEIF ( INCX.EQ.1 ) THEN +C +C Code for increment INCX = 1. +C + IF ( M.GT.0 ) THEN +C + DO 30 I = 1, M - 1 + CALL DLARTG( A(I,I), X(I), CI, SI, TEMP ) + A(I,I) = TEMP + CALL DROT( MN-I, A(I,I+1), LDA, X(I+1), 1, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, B(I,1), LDB, D, INCD, CI, SI ) + 30 CONTINUE +C + CALL DLARTG( A(M,M), X(M), CI, SI, TEMP ) + A(M,M) = TEMP + IF ( N.GT.0 ) + $ CALL DROT( N, A(M,M+1), LDA, X(M+1), 1, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, B(M,1), LDB, D, INCD, CI, SI ) + END IF +C + IF ( N.GT.0 ) THEN + IX = M + 1 +C + DO 40 I = 1, N - 1 + CALL DLARTG( T(I,I), X(IX), CI, SI, TEMP ) + T(I,I) = TEMP + IX = IX + 1 + CALL DROT( N-I, T(I,I+1), LDT, X(IX), 1, CI, SI ) + IF ( P.GT.0 ) + $ CALL DROT( P, C(I,1), LDC, D, INCD, CI, SI ) + 40 CONTINUE +C + CALL DLARTG( T(N,N), X(IX), CI, SI, TEMP ) + T(N,N) = TEMP + IF ( P.GT.0 ) + $ CALL DROT( P, C(N,1), LDC, D, INCD, CI, SI ) + END IF + END IF +C + RETURN +C *** Last line of MB04OW *** + END diff --git a/mex/sources/libslicot/MB04OX.f b/mex/sources/libslicot/MB04OX.f new file mode 100644 index 000000000..b8d02919e --- /dev/null +++ b/mex/sources/libslicot/MB04OX.f @@ -0,0 +1,106 @@ + SUBROUTINE MB04OX( N, A, LDA, X, INCX ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the QR factorization +C +C (U ) = Q*(R), +C (x') (0) +C +C where U and R are n-by-n upper triangular matrices, x is an +C n element vector and Q is an (n+1)-by-(n+1) orthogonal matrix. +C +C U must be supplied in the n-by-n upper triangular part of the +C array A and this is overwritten by R. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of elements of X and the order of the square +C matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix U. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular matrix R. +C The strict lower triangle of A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, the incremented array X must contain the +C vector x. On exit, the content of X is changed. +C +C INCX (input) INTEGER. +C Specifies the increment for the elements of X. INCX > 0. +C +C METHOD +C +C The matrix Q is formed as a sequence of plane rotations in planes +C (1, n+1), (2, n+1), ..., (n, n+1), the rotation in the (j, n+1)th +C plane, Q(j), being chosen to annihilate the jth element of x. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine DUTUPD. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INCX, LDA, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), X(*) +C .. Local Scalars .. + DOUBLE PRECISION CI, SI, TEMP + INTEGER I, IX +C .. External Subroutines .. + EXTERNAL DLARTG, DROT +C +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + IX = 1 +C + DO 20 I = 1, N - 1 + CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP ) + A(I,I) = TEMP + IX = IX + INCX + CALL DROT( N-I, A(I,I+1), LDA, X(IX), INCX, CI, SI ) + 20 CONTINUE +C + CALL DLARTG( A(N,N), X(IX), CI, SI, TEMP ) + A(N,N) = TEMP +C + RETURN +C *** Last line of MB04OX *** + END diff --git a/mex/sources/libslicot/MB04OY.f b/mex/sources/libslicot/MB04OY.f new file mode 100644 index 000000000..d77d28372 --- /dev/null +++ b/mex/sources/libslicot/MB04OY.f @@ -0,0 +1,370 @@ + SUBROUTINE MB04OY( M, N, V, TAU, A, LDA, B, LDB, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a real elementary reflector H to a real (m+1)-by-n +C matrix C = [ A ], from the left, where A has one row. H is +C [ B ] +C represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real m-vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix B. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices A and B. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension (M) +C The vector v in the representation of H. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading 1-by-N part of this array must +C contain the matrix A. +C On exit, the leading 1-by-N part of this array contains +C the updated matrix A (the first row of H * C). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= 1. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix B. +C On exit, the leading M-by-N part of this array contains +C the updated matrix B (the last m rows of H * C). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking the special +C structure of C into account. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997. +C Based on LAPACK routines DLARFX and DLATZM. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER LDA, LDB, M, N + DOUBLE PRECISION TAU +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), V( * ) +C .. Local Scalars .. + INTEGER J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2, + $ V3, V4, V5, V6, V7, V8, V9 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN +C +C Form H * C, where H has order m+1. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) M+1 +C +C Code for general M. Compute +C +C w := C'*u, C := C - tau * u * w'. +C + CALL DCOPY( N, A, LDA, DWORK, 1 ) + CALL DGEMV( 'Transpose', M, N, ONE, B, LDB, V, 1, ONE, DWORK, 1 ) + CALL DAXPY( N, -TAU, DWORK, 1, A, LDA ) + CALL DGER( M, N, -TAU, V, 1, DWORK, 1, B, LDB ) + GO TO 210 + 10 CONTINUE +C +C Special code for 1 x 1 Householder +C + T1 = ONE - TAU + DO 20 J = 1, N + A( 1, J ) = T1*A( 1, J ) + 20 CONTINUE + GO TO 210 + 30 CONTINUE +C +C Special code for 2 x 2 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + DO 40 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + 40 CONTINUE + GO TO 210 + 50 CONTINUE +C +C Special code for 3 x 3 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 60 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + 60 CONTINUE + GO TO 210 + 70 CONTINUE +C +C Special code for 4 x 4 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 80 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + 80 CONTINUE + GO TO 210 + 90 CONTINUE +C +C Special code for 5 x 5 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 100 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + 100 CONTINUE + GO TO 210 + 110 CONTINUE +C +C Special code for 6 x 6 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 120 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + 120 CONTINUE + GO TO 210 + 130 CONTINUE +C +C Special code for 7 x 7 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 140 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + 140 CONTINUE + GO TO 210 + 150 CONTINUE +C +C Special code for 8 x 8 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 160 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + 160 CONTINUE + GO TO 210 + 170 CONTINUE +C +C Special code for 9 x 9 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 180 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + V8*B( 8, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + B( 8, J ) = B( 8, J ) - SUM*T8 + 180 CONTINUE + GO TO 210 + 190 CONTINUE +C +C Special code for 10 x 10 Householder +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 200 J = 1, N + SUM = A( 1, J ) + V1*B( 1, J ) + V2*B( 2, J ) + V3*B( 3, J ) + + $ V4*B( 4, J ) + V5*B( 5, J ) + V6*B( 6, J ) + + $ V7*B( 7, J ) + V8*B( 8, J ) + V9*B( 9, J ) + A( 1, J ) = A( 1, J ) - SUM*TAU + B( 1, J ) = B( 1, J ) - SUM*T1 + B( 2, J ) = B( 2, J ) - SUM*T2 + B( 3, J ) = B( 3, J ) - SUM*T3 + B( 4, J ) = B( 4, J ) - SUM*T4 + B( 5, J ) = B( 5, J ) - SUM*T5 + B( 6, J ) = B( 6, J ) - SUM*T6 + B( 7, J ) = B( 7, J ) - SUM*T7 + B( 8, J ) = B( 8, J ) - SUM*T8 + B( 9, J ) = B( 9, J ) - SUM*T9 + 200 CONTINUE + 210 CONTINUE + RETURN +C *** Last line of MB04OY *** + END diff --git a/mex/sources/libslicot/MB04PA.f b/mex/sources/libslicot/MB04PA.f new file mode 100644 index 000000000..8ee27d01e --- /dev/null +++ b/mex/sources/libslicot/MB04PA.f @@ -0,0 +1,1105 @@ + SUBROUTINE MB04PA( LHAM, N, K, NB, A, LDA, QG, LDQG, XA, LDXA, + $ XG, LDXG, XQ, LDXQ, YA, LDYA, CS, TAU, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a Hamiltonian like matrix +C +C [ A G ] T T +C H = [ T ] , G = G , Q = Q, +C [ Q -A ] +C +C or a skew-Hamiltonian like matrix +C +C [ A G ] T T +C W = [ T ] , G = -G , Q = -Q, +C [ Q A ] +C +C so that elements below the (k+1)-th subdiagonal in the first nb +C columns of the (k+n)-by-n matrix A, and offdiagonal elements +C in the first nb columns and rows of the n-by-n matrix Q are zero. +C +C The reduction is performed by an orthogonal symplectic +C transformation UU'*H*UU and matrices U, XA, XG, XQ, and YA are +C returned so that +C +C [ Aout + U*XA'+ YA*U' Gout + U*XG'+ XG*U' ] +C UU'*H*UU = [ ]. +C [ Qout + U*XQ'+ XQ*U' -Aout'- XA*U'- U*YA' ] +C +C Similarly, +C +C [ Aout + U*XA'+ YA*U' Gout + U*XG'- XG*U' ] +C UU'*W*UU = [ ]. +C [ Qout + U*XQ'- XQ*U' Aout'+ XA*U'+ U*YA' ] +C +C This is an auxiliary routine called by MB04PB. +C +C ARGUMENTS +C +C Mode Parameters +C +C LHAM LOGICAL +C Specifies the type of matrix to be reduced: +C = .FALSE. : skew-Hamiltonian like W; +C = .TRUE. : Hamiltonian like H. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C K (input) INTEGER +C The offset of the reduction. Elements below the (K+1)-th +C subdiagonal in the first NB columns of A are reduced +C to zero. K >= 0. +C +C NB (input) INTEGER +C The number of columns/rows to be reduced. N > NB >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading (K+N)-by-N part of this array must +C contain the matrix A. +C On exit, the leading (K+N)-by-N part of this array +C contains the matrix Aout and in the zero part +C information about the elementary reflectors used to +C compute the reduction. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,K+N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N+K-by-N+1 part of this array must +C contain in the bottom left part the lower triangular part +C of the N-by-N matrix Q and in the remainder the upper +C trapezoidal part of the last N columns of the N+K-by-N+K +C matrix G. +C On exit, the leading N+K-by-N+1 part of this array +C contains parts of the matrices Q and G in the same fashion +C as on entry only that the zero parts of Q contain +C information about the elementary reflectors used to +C compute the reduction. Note that if LHAM = .FALSE. then +C the (K-1)-th and K-th subdiagonals are not referenced. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N+K). +C +C XA (output) DOUBLE PRECISION array, dimension (LDXA,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix XA. +C +C LDXA INTEGER +C The leading dimension of the array XA. LDXA >= MAX(1,N). +C +C XG (output) DOUBLE PRECISION array, dimension (LDXG,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix XG. +C +C LDXG INTEGER +C The leading dimension of the array XG. LDXG >= MAX(1,K+N). +C +C XQ (output) DOUBLE PRECISION array, dimension (LDXQ,2*NB) +C On exit, the leading N-by-(2*NB) part of this array +C contains the matrix XQ. +C +C LDXQ INTEGER +C The leading dimension of the array XQ. LDXQ >= MAX(1,N). +C +C YA (output) DOUBLE PRECISION array, dimension (LDYA,2*NB) +C On exit, the leading (K+N)-by-(2*NB) part of this array +C contains the matrix YA. +C +C LDYA INTEGER +C The leading dimension of the array YA. LDYA >= MAX(1,K+N). +C +C CS (output) DOUBLE PRECISION array, dimension (2*NB) +C On exit, the first 2*NB elements of this array contain the +C cosines and sines of the symplectic Givens rotations used +C to compute the reduction. +C +C TAU (output) DOUBLE PRECISION array, dimension (NB) +C On exit, the first NB elements of this array contain the +C scalar factors of some of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*NB) +C +C METHOD +C +C For details regarding the representation of the orthogonal +C symplectic matrix UU within the arrays A, QG, CS, TAU see the +C description of MB04PU. +C +C The contents of A and QG on exit are illustrated by the following +C example with n = 5, k = 2 and nb = 2: +C +C ( a r r a a ) ( g g r r g g ) +C ( a r r a a ) ( g g r r g g ) +C ( a r r a a ) ( q g r r g g ) +C A = ( r r r r r ), QG = ( t r r r r r ), +C ( u2 r r r r ) ( u1 t r r r r ) +C ( u2 u2 r a a ) ( u1 u1 r q g g ) +C ( u2 u2 r a a ) ( u1 u1 r q q g ) +C +C where a, g and q denote elements of the original matrices, r +C denotes a modified element, t denotes a scalar factor of an +C applied elementary reflector and ui denote elements of the +C matrix U. +C +C REFERENCES +C +C [1] C. F. VAN LOAN: +C A symplectic method for approximating all the eigenvalues of +C a Hamiltonian matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] D. KRESSNER: +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner (Technical Univ. Berlin, Germany) and +C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. +C +C REVISIONS +C +C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DLAPVL). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix, +C skew-Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D+0 ) +C .. Scalar Arguments .. + LOGICAL LHAM + INTEGER K, LDA, LDQG, LDXA, LDXG, LDXQ, LDYA, N, NB +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*), + $ XA(LDXA,*), XG(LDXG,*), XQ(LDXQ,*), YA(LDYA,*) +C .. Local Scalars .. + INTEGER I, J, NB1, NB2 + DOUBLE PRECISION AKI, ALPHA, C, S, TAUQ, TEMP, TTEMP +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DLARFG, DLARTG, DROT, DSCAL, + $ DSYMV, MB01MD +C .. Intrinsic Functions .. + INTRINSIC MIN +C +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( N+K.LE.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + NB1 = NB + 1 + NB2 = NB + NB1 +C + IF ( LHAM ) THEN + DO 50 I = 1, NB +C +C Transform i-th columns of A and Q. See routine MB04PU. +C + ALPHA = QG(K+I+1,I) + CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) + QG(K+I+1,I) = ONE + TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) + AKI = A(K+I+1,I) + CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) + AKI = A(K+I+1,I) + CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) + A(K+I+1,I) = ONE +C +C Update XA with first Householder reflection. +C +C xa = H(1:n,1:n)'*u1 + CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, + $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) +C w1 = U1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, + $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) +C xa = xa + XA1*w1 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) +C w2 = U2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) +C xa = xa + XA2*w2 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) +C temp = YA1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) +C xa = xa + U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) +C temp = YA2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) +C xa = xa + U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) +C xa = -tauq*xa + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update YA with first Householder reflection. +C +C ya = H(1:n,1:n)*u1 + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) +C temp = XA1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U1*temp + CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) +C temp = XA2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U2*temp + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) +C ya = ya + YA1*w1 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) +C ya = ya + YA2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) +C ya = -tauq*ya + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C temp = -tauq*ya'*u1 + TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) +C ya = ya + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) +C +C Update (i+1)-th column of A. +C +C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, + $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, + $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, + $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) +C +C Update (i+1)-th row of A. +C + IF ( N.GT.I+1 ) THEN +C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), + $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), + $ LDA ) + END IF +C +C Annihilate updated parts in YA. +C + DO 10 J = 1, I + YA(K+I+1,J) = ZERO + 10 CONTINUE + DO 20 J = 1, I-1 + YA(K+I+1,NB+J) = ZERO + 20 CONTINUE +C +C Update XQ with first Householder reflection. +C +C xq = Q*u1 + CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, + $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) +C xq = xq + XQ1*w1 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) +C xq = xq + XQ2*w2 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) +C temp = XQ1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) +C xq = xq + U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) +C temp = XQ2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) +C xq = xq + U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) +C xq = -tauq*xq + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C temp = -tauq/2*xq'*u1 + TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) +C xq = xq + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) +C +C Update (i+1)-th column and row of Q. +C +C Q(:,i+1) = Q(:,i+1) + U1 * XQ1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, + $ XQ(I+1,1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) +C Q(:,i+1) = Q(:,i+1) + U2 * XQ2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XQ(I+1,NB1), LDXQ, ONE, QG(K+I+1,I+1), 1 ) +C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, XQ(I+1,1), LDXQ, + $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+1), 1 ) +C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+1), 1 ) +C +C Update XG with first Householder reflection. +C +C xg = G*u1 + CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, + $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) + CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, + $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) +C xg = xg + XG1*w1 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) +C xg = xg + XG2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) +C temp = XG1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg + U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) +C temp = XG2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), + $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg + U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) +C xg = -tauq*xg + CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) +C temp = -tauq/2*xq'*u1 + TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), + $ 1 ) +C xg = xg + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) +C +C Update (i+1)-th column and row of G. +C +C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, + $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) +C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, + $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) +C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, XG(K+I+1,1), LDXG, + $ QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+2), LDQG ) +C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XG(K+I+1,NB1), + $ LDXG, A(K+I+1,1), LDA, ONE, QG(K+I+1,I+2), + $ LDQG ) +C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, + $ XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) +C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+2), LDQG ) +C +C Annihilate updated parts in XG. +C + DO 30 J = 1, I + XG(K+I+1,J) = ZERO + 30 CONTINUE + DO 40 J = 1, I-1 + XG(K+I+1,NB+J) = ZERO + 40 CONTINUE +C +C Apply orthogonal symplectic Givens rotation. +C + CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) + IF ( N.GT.I+1 ) THEN + CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, + $ C, S ) + CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, C, + $ S ) + END IF + TEMP = A(K+I+1,I+1) + TTEMP = QG(K+I+1,I+2) + A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+1) + QG(K+I+1,I+2) = C*TTEMP - S*TEMP + QG(K+I+1,I+1) = -S*TEMP + C*QG(K+I+1,I+1) + TTEMP = -S*TTEMP - C*TEMP + TEMP = A(K+I+1,I+1) + QG(K+I+1,I+1) = C*QG(K+I+1,I+1) + S*TTEMP + A(K+I+1,I+1) = C*TEMP + S*QG(K+I+1,I+2) + QG(K+I+1,I+2) = -S*TEMP + C*QG(K+I+1,I+2) + CS(2*I-1) = C + CS(2*I) = S + QG(K+I+1,I) = TAUQ +C +C Update XA with second Householder reflection. +C +C xa = H(1:n,1:n)'*u2 + CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, + $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C w1 = U1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) +C xa = xa + XA1*w1 + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), + $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) +C w2 = U2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) +C xa = xa + XA2*w2 + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) +C temp = YA1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), + $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) +C xa = xa + U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) +C temp = YA2'*u1 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), + $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) +C xa = xa + U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) + END IF +C xa = -tau*xa + CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) +C +C Update YA with second Householder reflection. +C +C ya = H(1:n,1:n)*u2 + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C temp = XA1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U1*temp + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) +C temp = XA2'*u1 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U2*temp + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) + END IF +C ya = ya + YA1*w1 + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,NB+I), 1 ) +C ya = ya + YA2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) +C ya = -tau*ya + CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) +C temp = -tau*ya'*u2 + TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) +C ya = ya + temp*u2 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) +C +C Update (i+1)-th column of A. +C +C H(1:n,i+1) = H(1:n,i+1) + ya + CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) +C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 + CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), + $ 1 ) +C +C Update (i+1)-th row of A. +C + IF ( N.GT.I+1 ) THEN +C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; + CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), + $ LDA ) +C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' + CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, + $ A(K+I+1,I+2), LDA ) + END IF +C +C Annihilate updated parts in YA. +C + YA(K+I+1,NB+I) = ZERO +C +C Update XQ with second Householder reflection. +C +C xq = Q*u2 + CALL DSYMV( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, + $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C xq = xq + XQ1*w1 + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), + $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) +C xq = xq + XQ2*w2 + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) +C temp = XQ1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) +C xq = xq + U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) +C temp = XQ2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) +C xq = xq + U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) + END IF +C xq = -tauq*xq + CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) +C temp = -tauq/2*xq'*u2 + TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), + $ 1 ) +C xq = xq + temp*u2 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) +C +C Update (i+1)-th column and row of Q. +C + CALL DAXPY( N-I, ONE, XQ(I+1,NB+I), 1, QG(K+I+1,I+1), 1 ) +C H(1:n,n+i+1) = H(1:n,n+i+1) + U * XQ(i+1,:)'; + CALL DAXPY( N-I, XQ(I+1,NB+I), A(K+I+1,I), 1, + $ QG(K+I+1,I+1), 1 ) +C +C Update XG with second Householder reflection. +C +C xg = G*u2 + CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, + $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) + CALL DSYMV( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, + $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) +C xg = xg + XG1*w1 + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,NB+I), 1 ) +C xg = xg + XG2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C temp = XG1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), + $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg + U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) +C temp = XG2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), + $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg + U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) + END IF +C xg = -tauq*xg + CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) +C temp = -tauq/2*xg'*u1 + TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, + $ XG(K+I+1,NB+I), 1 ) +C xg = xg + temp*u1 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) +C +C Update (i+1)-th column and row of G. +C + CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) + CALL DAXPY( N-I, ONE, XG(K+I+1,NB+I), 1, QG(K+I+1,I+2), + $ LDQG ) + CALL DAXPY( N-I, XG(K+I+1,NB+I), A(K+I+1,I), 1, + $ QG(K+I+1,I+2), LDQG ) +C +C Annihilate updated parts in XG. +C + XG(K+I+1,NB+I) = ZERO +C + A(K+I+1,I) = AKI + 50 CONTINUE + ELSE + DO 100 I = 1, NB +C +C Transform i-th columns of A and Q. +C + ALPHA = QG(K+I+1,I) + CALL DLARFG( N-I, ALPHA, QG(K+MIN( I+2, N ),I), 1, TAUQ ) + QG(K+I+1,I) = ONE + TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, A(K+I+1,I), 1 ) + AKI = A(K+I+1,I) + CALL DLARTG( AKI, ALPHA, C, S, A(K+I+1,I) ) + AKI = A(K+I+1,I) + CALL DLARFG( N-I, AKI, A(K+MIN( I+2, N ),I), 1, TAU(I) ) + A(K+I+1,I) = ONE +C +C Update XA with first Householder reflection. +C +C xa = H(1:n,1:n)'*u1 + CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, + $ QG(K+I+1,I), 1, ZERO, XA(I+1,I), 1 ) +C w1 = U1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, QG(K+I+1,1), LDQG, + $ QG(K+I+1,I), 1, ZERO, DWORK, 1 ) +C xa = xa + XA1*w1 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ DWORK, 1, ONE, XA(I+1,I), 1 ) +C w2 = U2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB1), 1 ) +C xa = xa + XA2*w2 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XA(I+1,NB1), + $ LDXA, DWORK(NB1), 1, ONE, XA(I+1,I), 1 ) +C temp = YA1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,1), LDYA, + $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) +C xa = xa + U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, XA(1,I), 1, ONE, XA(I+1,I), 1 ) +C temp = YA2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, YA(K+I+1,NB1), LDYA, + $ QG(K+I+1,I), 1, ZERO, XA(1,I), 1 ) +C xa = xa + U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XA(1,I), 1, ONE, XA(I+1,I), 1 ) +C xa = -tauq*xa + CALL DSCAL( N-I, -TAUQ, XA(I+1,I), 1 ) +C +C Update YA with first Householder reflection. +C +C ya = H(1:n,1:n)*u1 + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ QG(K+I+1,I), 1, ZERO, YA(1,I), 1 ) +C temp = XA1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,1), LDXA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U1*temp + CALL DGEMV( 'No transpose', N-I, I-1, ONE, QG(K+I+1,1), + $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) +C temp = XA2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XA(I+1,NB1), LDXA, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U2*temp + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ DWORK(NB2), 1, ONE, YA(K+I+1,I), 1 ) +C ya = ya + YA1*w1 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,I), 1 ) +C ya = ya + YA2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB1), 1, ONE, YA(1,I), 1 ) +C ya = -tauq*ya + CALL DSCAL( K+N, -TAUQ, YA(1,I), 1 ) +C temp = -tauq*ya'*u1 + TEMP = -TAUQ*DDOT( N-I, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) +C ya = ya + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, YA(K+I+1,I), 1 ) +C +C Update (i+1)-th column of A. +C +C A(:,i+1) = A(:,i+1) + U1 * XA1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I, ONE, QG(K+I+1,1), LDQG, + $ XA(I+1,1), LDXA, ONE, A(K+I+1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + U2 * XA2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I, I-1, ONE, A(K+I+1,1), LDA, + $ XA(I+1,NB1), LDXA, ONE, A(K+I+1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + YA1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N+K, I, ONE, YA, LDYA, + $ QG(K+I+1,1), LDQG, ONE, A(1,I+1), 1 ) +C A(:,i+1) = A(:,i+1) + YA2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N+K, I-1, ONE, YA(1,NB1), LDYA, + $ A(K+I+1,1), LDA, ONE, A(1,I+1), 1 ) +C +C Update (i+1)-th row of A. +C + IF ( N.GT.I+1 ) THEN +C A(i+1,i+2:n) = A(i+1,i+2:n) + U1(i+1,:)*XA1(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), + $ LDXA, QG(K+I+1,1), LDQG, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + U2(i+1,:)*XA2(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, A(K+I+1,1), LDA, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + YA1(i+1,:) * U1(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, YA(K+I+1,1), LDYA, ONE, A(K+I+1,I+2), + $ LDA ) +C A(i+1,i+2:n) = A(i+1,i+2:n) + YA2(i+1,:) * U2(i+2:n,:)' + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, YA(K+I+1,NB1), LDYA, ONE, A(K+I+1,I+2), + $ LDA ) + END IF +C +C Annihilate updated parts in YA. +C + DO 60 J = 1, I + YA(K+I+1,J) = ZERO + 60 CONTINUE + DO 70 J = 1, I-1 + YA(K+I+1,NB+J) = ZERO + 70 CONTINUE +C +C Update XQ with first Householder reflection. +C +C xq = Q*u1 + CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, + $ QG(K+I+1,I), 1, ZERO, XQ(I+1,I), 1 ) +C xq = xq + XQ1*w1 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ DWORK, 1, ONE, XQ(I+1,I), 1 ) +C xq = xq + XQ2*w2 + CALL DGEMV( 'No transpose', N-I, I-1, ONE, XQ(I+1,NB1), + $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+1,I), 1 ) +C temp = XQ1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) +C xq = xq - U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), + $ LDQG, XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) +C temp = XQ2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XQ(I+1,NB1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, XQ(1,I), 1 ) +C xq = xq - U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, + $ XQ(1,I), 1, ONE, XQ(I+1,I), 1 ) +C xq = -tauq*xq + CALL DSCAL( N-I, -TAUQ, XQ(I+1,I), 1 ) +C temp = -tauq/2*xq'*u1 + TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) +C xq = xq + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XQ(I+1,I), 1 ) +C +C Update (i+1)-th column and row of Q. +C + IF ( N.GT.I+1 ) THEN +C Q(:,i+1) = Q(:,i+1) - U1 * XQ1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I, -ONE, QG(K+I+2,1), + $ LDQG, XQ(I+1,1), LDXQ, ONE, QG(K+I+2,I+1), + $ 1 ) +C Q(:,i+1) = Q(:,i+1) - U2 * XQ2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, A(K+I+2,1), + $ LDA, XQ(I+1,NB1), LDXQ, ONE, QG(K+I+2,I+1), + $ 1 ) +C Q(:,i+1) = Q(:,i+1) + XQ1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), + $ LDXQ, QG(K+I+1,1), LDQG, ONE, QG(K+I+2,I+1), + $ 1 ) +C Q(:,i+1) = Q(:,i+1) + XQ2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, A(K+I+1,1), LDA, ONE, QG(K+I+2,I+1), + $ 1 ) + END IF +C +C Update XG with first Householder reflection. +C +C xg = G*u1 + CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, + $ QG(K+I+1,I), 1, ZERO, XG(1,I), 1 ) + CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, + $ QG(K+I+1,I), 1, ZERO, XG(K+I+1,I), 1 ) +C xg = xg + XG1*w1 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,I), 1 ) +C xg = xg + XG2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB1), 1, ONE, XG(1,I), 1 ) +C temp = XG1'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,1), LDXQ, + $ QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg - U1*temp + CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, QG(K+I+1,1), + $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) +C temp = XG2'*u1 + CALL DGEMV( 'Transpose', N-I, I-1, ONE, XG(K+I+1,NB1), + $ LDXQ, QG(K+I+1,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg - U2*temp + CALL DGEMV( 'No Transpose', N-I, I-1, -ONE, A(K+I+1,1), LDA, + $ DWORK(NB2), 1, ONE, XG(K+I+1,I), 1 ) +C xg = -tauq*xg + CALL DSCAL( N+K, -TAUQ, XG(1,I), 1 ) +C temp = -tauq/2*xq'*u1 + TEMP = -HALF*TAUQ*DDOT( N-I, QG(K+I+1,I), 1, XG(K+I+1,I), + $ 1 ) +C xg = xg + temp*u1 + CALL DAXPY( N-I, TEMP, QG(K+I+1,I), 1, XG(K+I+1,I), 1 ) +C +C Update (i+1)-th column and row of G. +C +C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', K+I, I, ONE, XG, LDXG, + $ QG(K+I+1,1), LDQG, ONE, QG(1,I+2), 1 ) +C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', K+I, I-1, ONE, XG(1,NB1), LDXG, + $ A(K+I+1,1), LDA, ONE, QG(1,I+2), 1 ) + IF ( N.GT.I+1 ) THEN +C G(:,i+1) = G(:,i+1) + XG1 * U1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I, -ONE, XG(K+I+2,1), + $ LDXG, QG(K+I+1,1), LDQG, ONE, QG(K+I+1,I+3), + $ LDQG ) +C G(:,i+1) = G(:,i+1) + XG2 * U2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I-1, -ONE, + $ XG(K+I+2,NB1), LDXG, A(K+I+1,1), LDA, ONE, + $ QG(K+I+1,I+3), LDQG ) +C G(:,i+1) = G(:,i+1) + U1 * XG1(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, XG(K+I+1,1), LDXG, ONE, QG(K+I+1,I+3), + $ LDQG ) +C G(:,i+1) = G(:,i+1) + U2 * XG2(i+1,:)'; + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, XG(K+I+1,NB1), LDXG, ONE, QG(K+I+1,I+3), + $ LDQG ) + END IF +C +C Annihilate updated parts in XG. +C + DO 80 J = 1, I + XG(K+I+1,J) = ZERO + 80 CONTINUE + DO 90 J = 1, I-1 + XG(K+I+1,NB+J) = ZERO + 90 CONTINUE +C +C Apply orthogonal symplectic Givens rotation. +C + CALL DROT( K+I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) + IF ( N.GT.I+1 ) THEN + CALL DROT( N-I-1, A(K+I+2,I+1), 1, QG(K+I+1,I+3), LDQG, + $ C, -S ) + CALL DROT( N-I-1, A(K+I+1,I+2), LDA, QG(K+I+2,I+1), 1, + $ C, -S ) + END IF + CS(2*I-1) = C + CS(2*I) = S + QG(K+I+1,I) = TAUQ +C +C Update XA with second Householder reflection. +C +C xa = H(1:n,1:n)'*u2 + CALL DGEMV( 'Transpose', N-I, N-I, ONE, A(K+I+1,I+1), LDA, + $ A(K+I+1,I), 1, ZERO, XA(I+1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C w1 = U1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, A(K+I+2,I), 1, ZERO, DWORK, 1 ) +C xa = xa + XA1*w1 + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XA(I+2,1), + $ LDXA, DWORK, 1, ONE, XA(I+2,NB+I), 1 ) +C w2 = U2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, A(K+I+2,I), 1, ZERO, DWORK(NB1), 1 ) +C xa = xa + XA2*w2 + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, DWORK(NB1), 1, ONE, XA(I+2,NB+I), 1 ) +C temp = YA1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, YA(K+I+2,1), + $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) +C xa = xa + U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) +C temp = YA2'*u1 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, YA(K+I+2,NB1), + $ LDYA, A(K+I+2,I), 1, ZERO, XA(1,NB+I), 1 ) +C xa = xa + U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, XA(1,NB+I), 1, ONE, XA(I+2,NB+I), 1 ) + END IF +C xa = -tau*xa + CALL DSCAL( N-I, -TAU(I), XA(I+1,NB+I), 1 ) +C +C Update YA with second Householder reflection. +C +C ya = H(1:n,1:n)*u2 + CALL DGEMV( 'No transpose', K+N, N-I, ONE, A(1,I+1), LDA, + $ A(K+I+1,I), 1, ZERO, YA(1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C temp = XA1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XA(I+2,1), LDXA, + $ A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U1*temp + CALL DGEMV( 'No transpose', N-I-1, I, ONE, QG(K+I+2,1), + $ LDQG, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) +C temp = XA2'*u1 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XA(I+2,NB1), + $ LDXA, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C ya = ya + U2*temp + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, A(K+I+2,1), + $ LDA, DWORK(NB2), 1, ONE, YA(K+I+2,NB+I), 1 ) + END IF +C ya = ya + YA1*w1 + CALL DGEMV( 'No transpose', K+N, I, ONE, YA, LDYA, + $ DWORK, 1, ONE, YA(1,NB+I), 1 ) +C ya = ya + YA2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, YA(1,NB1), LDYA, + $ DWORK(NB1), 1, ONE, YA(1,NB+I), 1 ) +C ya = -tau*ya + CALL DSCAL( K+N, -TAU(I), YA(1,NB+I), 1 ) +C temp = -tau*ya'*u2 + TEMP = -TAU(I)*DDOT( N-I, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) +C ya = ya + temp*u2 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, YA(K+I+1,NB+I), 1 ) +C +C Update (i+1)-th column of A. +C +C H(1:n,i+1) = H(1:n,i+1) + ya + CALL DAXPY( K+N, ONE, YA(1,NB+I), 1, A(1,I+1), 1 ) +C H(1:n,i+1) = H(1:n,i+1) + xa(i+1)*u2 + CALL DAXPY( N-I, XA(I+1,NB+I), A(K+I+1,I), 1, A(K+I+1,I+1), + $ 1 ) +C +C Update (i+1)-th row of A. +C + IF ( N.GT.I+1 ) THEN +C H(i+1,i+2:n) = H(i+1,i+2:n) + xa(i+2:n)'; + CALL DAXPY( N-I-1, ONE, XA(I+2,NB+I), 1, A(K+I+1,I+2), + $ LDA ) +C H(i+1,i+2:n) = H(i+1,i+2:n) + YA(i+1,:) * U(i+2:n,:)' + CALL DAXPY( N-I-1, YA(K+I+1,NB+I), A(K+I+2,I), 1, + $ A(K+I+1,I+2), LDA ) + END IF +C +C Annihilate updated parts in YA. +C + YA(K+I+1,NB+I) = ZERO +C +C Update XQ with second Householder reflection. +C +C xq = Q*u2 + CALL MB01MD( 'Lower', N-I, ONE, QG(K+I+1,I+1), LDQG, + $ A(K+I+1,I), 1, ZERO, XQ(I+1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C xq = xq + XQ1*w1 + CALL DGEMV( 'No transpose', N-I-1, I, ONE, XQ(I+2,1), + $ LDXQ, DWORK, 1, ONE, XQ(I+2,NB+I), 1 ) +C xq = xq + XQ2*w2 + CALL DGEMV( 'No transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, DWORK(NB1), 1, ONE, XQ(I+2,NB+I), 1 ) +C temp = XQ1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XQ(I+2,1), LDXQ, + $ A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) +C xq = xq - U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), + $ LDQG, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) +C temp = XQ2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XQ(I+2,NB1), + $ LDXQ, A(K+I+2,I), 1, ZERO, XQ(1,NB+I), 1 ) +C xq = xq - U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), + $ LDA, XQ(1,NB+I), 1, ONE, XQ(I+2,NB+I), 1 ) + END IF +C xq = -tauq*xq + CALL DSCAL( N-I, -TAU(I), XQ(I+1,NB+I), 1 ) +C temp = -tauq/2*xq'*u2 + TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, XQ(I+1,NB+I), + $ 1 ) +C xq = xq + temp*u2 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XQ(I+1,NB+I), 1 ) +C +C Update (i+1)-th column and row of Q. +C + IF ( N.GT.I+1 ) THEN + CALL DAXPY( N-I-1, ONE, XQ(I+2,NB+I), 1, QG(K+I+2,I+1), + $ 1 ) +C H(1:n,n+i+1) = H(1:n,n+i+1) - U * XQ(i+1,:)'; + CALL DAXPY( N-I-1, -XQ(I+1,NB+I), A(K+I+2,I), 1, + $ QG(K+I+2,I+1), 1 ) + END IF +C +C Update XG with second Householder reflection. +C +C xg = G*u2 + CALL DGEMV( 'No transpose', K+I, N-I, ONE, QG(1,I+2), LDQG, + $ A(K+I+1,I), 1, ZERO, XG(1,NB+I), 1 ) + CALL MB01MD( 'Upper', N-I, ONE, QG(K+I+1,I+2), LDQG, + $ A(K+I+1,I), 1, ZERO, XG(K+I+1,NB+I), 1 ) +C xg = xg + XG1*w1 + CALL DGEMV( 'No transpose', K+N, I, ONE, XG, LDXG, + $ DWORK, 1, ONE, XG(1,NB+I), 1 ) +C xg = xg + XG2*w2 + CALL DGEMV( 'No transpose', K+N, I-1, ONE, XG(1,NB1), + $ LDXG, DWORK(NB1), 1, ONE, XG(1,NB+I), 1 ) + IF ( N.GT.I+1 ) THEN +C temp = XG1'*u2 + CALL DGEMV( 'Transpose', N-I-1, I, ONE, XG(K+I+2,1), + $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg - U1*temp + CALL DGEMV( 'No Transpose', N-I-1, I, -ONE, QG(K+I+2,1), + $ LDQG, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) +C temp = XG2'*u2 + CALL DGEMV( 'Transpose', N-I-1, I-1, ONE, XG(K+I+2,NB1), + $ LDXQ, A(K+I+2,I), 1, ZERO, DWORK(NB2), 1 ) +C xg = xg - U2*temp + CALL DGEMV( 'No Transpose', N-I-1, I-1, -ONE, A(K+I+2,1), + $ LDA, DWORK(NB2), 1, ONE, XG(K+I+2,NB+I), 1 ) + END IF +C xg = -tauq*xg + CALL DSCAL( N+K, -TAU(I), XG(1,NB+I), 1 ) +C temp = -tauq/2*xg'*u1 + TEMP = -HALF*TAU(I)*DDOT( N-I, A(K+I+1,I), 1, + $ XG(K+I+1,NB+I), 1 ) +C xg = xg + temp*u1 + CALL DAXPY( N-I, TEMP, A(K+I+1,I), 1, XG(K+I+1,NB+I), 1 ) +C +C Update (i+1)-th column and row of G. +C + CALL DAXPY( K+I, ONE, XG(1,NB+I), 1, QG(1,I+2), 1 ) + IF ( N.GT.I+1 ) THEN + CALL DAXPY( N-I-1, -ONE, XG(K+I+2,NB+I), 1, + $ QG(K+I+1,I+3), LDQG ) + CALL DAXPY( N-I-1, XG(K+I+1,NB+I), A(K+I+2,I), 1, + $ QG(K+I+1,I+3), LDQG ) + END IF +C +C Annihilate updated parts in XG. +C + XG(K+I+1,NB+I) = ZERO +C + A(K+I+1,I) = AKI + 100 CONTINUE + END IF +C + RETURN +C *** Last line of MB04PA *** + END diff --git a/mex/sources/libslicot/MB04PB.f b/mex/sources/libslicot/MB04PB.f new file mode 100644 index 000000000..3948eee1e --- /dev/null +++ b/mex/sources/libslicot/MB04PB.f @@ -0,0 +1,333 @@ + SUBROUTINE MB04PB( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a Hamiltonian matrix, +C +C [ A G ] +C H = [ T ] , +C [ Q -A ] +C +C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, +C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U +C is computed so that +C +C T [ Aout Gout ] +C U H U = [ T ] , +C [ Qout -Aout ] +C +C where Aout is upper Hessenberg and Qout is diagonal. +C Blocked version. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ILO (input) INTEGER +C It is assumed that A is already upper triangular and Q is +C zero in rows and columns 1:ILO-1. ILO is normally set by a +C previous call to MB04DD; otherwise it should be set to 1. +C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Aout and, in the zero part of Aout, +C information about the elementary reflectors used to +C compute the PVL factorization. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain the lower triangular part of the matrix Q and +C the upper triangular part of the matrix G. +C On exit, the leading N-by-N+1 part of this array contains +C the diagonal of the matrix Qout, the upper triangular part +C of the matrix Gout and, in the zero parts of Qout, +C information about the elementary reflectors used to +C compute the PVL factorization. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C CS (output) DOUBLE PRECISION array, dimension (2N-2) +C On exit, the first 2N-2 elements of this array contain the +C cosines and sines of the symplectic Givens rotations used +C to compute the PVL factorization. +C +C TAU (output) DOUBLE PRECISION array, dimension (N-1) +C On exit, the first N-1 elements of this array contain the +C scalar factors of some of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK, 8*N*NB + 3*NB, where NB is the optimal +C block size determined by the function UE01MD. +C On exit, if INFO = -10, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N-1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix U is represented as a product of symplectic reflectors +C and Givens rotators +C +C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). +C +C Each H(i) has the form +C +C H(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in +C QG(i+2:n,i), and tau in QG(i+1,i). +C +C Each F(i) has the form +C +C F(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in +C A(i+2:n,i), and nu in TAU(i). +C +C Each G(i) is a Givens rotator acting on rows i+1 and n+i+1, +C where the cosine is stored in CS(2*i-1) and the sine in +C CS(2*i). +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**3) floating point operations and is +C strongly backward stable. +C +C REFERENCES +C +C [1] C. F. VAN LOAN: +C A symplectic method for approximating all the eigenvalues of +C a Hamiltonian matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] D. KRESSNER: +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner (Technical Univ. Berlin, Germany) and +C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. +C +C REVISIONS +C +C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVB). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER ILO, INFO, LDA, LDQG, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) +C .. Local Scalars .. + INTEGER I, IB, IERR, NB, NBMIN, NH, NIB, NNB, NX, PDW, + $ PXA, PXG, PXQ, PYA, WRKOPT +C .. External Functions .. + INTEGER UE01MD + EXTERNAL UE01MD +C .. External Subroutines .. + EXTERNAL DGEMM, DSYR2K, MB04PA, MB04PU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN + DWORK(1) = DBLE( MAX( 1, N-1 ) ) + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04PB', -INFO ) + RETURN + END IF +C +C Set elements 1:ILO-1 of TAU and CS. +C + DO 10 I = 1, ILO - 1 + TAU( I ) = ZERO + CS(2*I-1) = ONE + CS(2*I) = ZERO + 10 CONTINUE +C +C Quick return if possible. +C + IF ( N.LE.ILO ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Determine the block size. +C + NH = N - ILO + 1 + NB = UE01MD( 1, 'MB04PB', ' ', N, ILO, -1 ) + NBMIN = 2 + WRKOPT = N-1 + IF ( NB.GT.1 .AND. NB.LT.NH ) THEN +C +C Determine when to cross over from blocked to unblocked code. +C + NX = MAX( NB, UE01MD( 3, 'MB04PB', ' ', N, ILO, -1 ) ) + IF ( NX.LT.NH ) THEN +C +C Check whether workspace is large enough for blocked code. +C + WRKOPT = 8*N*NB + 3*NB + IF ( LDWORK.LT.WRKOPT ) THEN +C +C Not enough workspace available. Determine minimum value +C of NB, and reduce NB. +C + NBMIN = MAX( 2, UE01MD( 2, 'MB04PB', ' ', N, ILO, -1 ) ) + NB = LDWORK / ( 8*N + 3 ) + END IF + END IF + END IF +C + NNB = N*NB + PXA = 1 + PYA = PXA + 2*NNB + PXQ = PYA + 2*NNB + PXG = PXQ + 2*NNB + PDW = PXG + 2*NNB +C + IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +C +C Use unblocked code. +C + I = ILO +C + ELSE + DO 20 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to PVL form and return the +C matrices XA, XG, XQ, and YA which are needed to update the +C unreduced parts of the matrices. +C + CALL MB04PA( .TRUE., N-I+1, I-1, IB, A(1,I), LDA, QG(1,I), + $ LDQG, DWORK(PXA), N, DWORK(PXG), N, + $ DWORK(PXQ), N, DWORK(PYA), N, CS(2*I-1), + $ TAU(I), DWORK(PDW) ) + IF ( N.GT.I+IB ) THEN +C +C Update the submatrix A(1:n,i+ib+1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, + $ IB, ONE, QG(I+IB+1,I), LDQG, DWORK(PXA+IB+1), + $ N, ONE, A(I+IB+1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB, + $ IB, ONE, A(I+IB+1,I), LDA, + $ DWORK(PXA+NIB+IB+1), N, ONE, + $ A(I+IB+1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA), N, QG(I+IB+1,I), LDQG, ONE, + $ A(1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA+NIB), N, A(I+IB+1,I), LDA, + $ ONE, A(1,I+IB+1), LDA ) +C +C Update the submatrix Q(i+ib+1:n,i+ib+1:n). +C + CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, + $ DWORK(PXQ+IB+1), N, QG(I+IB+1,I), LDQG, ONE, + $ QG(I+IB+1,I+IB+1), LDQG ) + CALL DSYR2K( 'Lower', 'No Transpose', N-I-IB, IB, ONE, + $ DWORK(PXQ+NIB+IB+1), N, A(I+IB+1,I), LDA, + $ ONE, QG(I+IB+1,I+IB+1), LDQG ) +C +C Update the submatrix G(1:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, + $ IB, ONE, DWORK(PXG), N, QG(I+IB+1,I), LDQG, + $ ONE, QG(1,I+IB+2), LDQG ) + CALL DGEMM( 'No transpose', 'Transpose', I+IB, N-I-IB, + $ IB, ONE, DWORK(PXG+NIB), N, A(I+IB+1,I), LDA, + $ ONE, QG(1,I+IB+2), LDQG ) + CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, + $ DWORK(PXG+IB+I), N, QG(I+IB+1,I), LDQG, ONE, + $ QG(I+IB+1,I+IB+2), LDQG ) + CALL DSYR2K( 'Upper', 'No Transpose', N-I-IB, IB, ONE, + $ DWORK(PXG+NIB+IB+I), N, A(I+IB+1,I), LDA, + $ ONE, QG(I+IB+1,I+IB+2), LDQG ) + END IF + 20 CONTINUE + END IF +C +C Unblocked code to reduce the rest of the matrices. +C + CALL MB04PU( N, I, A, LDA, QG, LDQG, CS, TAU, DWORK, LDWORK, + $ IERR ) +C + DWORK( 1 ) = DBLE( WRKOPT ) +C + RETURN +C *** Last line of MB04PB *** + END diff --git a/mex/sources/libslicot/MB04PU.f b/mex/sources/libslicot/MB04PU.f new file mode 100644 index 000000000..2c13e6636 --- /dev/null +++ b/mex/sources/libslicot/MB04PU.f @@ -0,0 +1,369 @@ + SUBROUTINE MB04PU( N, ILO, A, LDA, QG, LDQG, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a Hamiltonian matrix, +C +C [ A G ] +C H = [ T ] , +C [ Q -A ] +C +C where A is an N-by-N matrix and G,Q are N-by-N symmetric matrices, +C to Paige/Van Loan (PVL) form. That is, an orthogonal symplectic U +C is computed so that +C +C T [ Aout Gout ] +C U H U = [ T ] , +C [ Qout -Aout ] +C +C where Aout is upper Hessenberg and Qout is diagonal. +C Unblocked version. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ILO (input) INTEGER +C It is assumed that A is already upper triangular and Q is +C zero in rows and columns 1:ILO-1. ILO is normally set by a +C previous call to MB04DD; otherwise it should be set to 1. +C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Aout and, in the zero part of Aout, +C information about the elementary reflectors used to +C compute the PVL factorization. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On entry, the leading N-by-N+1 part of this array must +C contain the lower triangular part of the matrix Q and +C the upper triangular part of the matrix G. +C On exit, the leading N-by-N+1 part of this array contains +C the diagonal of the matrix Qout, the upper triangular part +C of the matrix Gout and, in the zero parts of Qout, +C information about the elementary reflectors used to +C compute the PVL factorization. +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C CS (output) DOUBLE PRECISION array, dimension (2N-2) +C On exit, the first 2N-2 elements of this array contain the +C cosines and sines of the symplectic Givens rotations used +C to compute the PVL factorization. +C +C TAU (output) DOUBLE PRECISION array, dimension (N-1) +C On exit, the first N-1 elements of this array contain the +C scalar factors of some of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -10, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N-1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix U is represented as a product of symplectic reflectors +C and Givens rotators +C +C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). +C +C Each H(i) has the form +C +C H(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in +C QG(i+2:n,i), and tau in QG(i+1,i). +C +C Each F(i) has the form +C +C F(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in +C A(i+2:n,i), and nu in TAU(i). +C +C Each G(i) is a Givens rotator acting on rows i+1 and n+i+1, +C where the cosine is stored in CS(2*i-1) and the sine in +C CS(2*i). +C +C NUMERICAL ASPECTS +C +C The algorithm requires 40/3 N**3 + O(N) floating point operations +C and is strongly backward stable. +C +C REFERENCES +C +C [1] C. F. VAN LOAN: +C A symplectic method for approximating all the eigenvalues of +C a Hamiltonian matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C CONTRIBUTORS +C +C D. Kressner (Technical Univ. Berlin, Germany) and +C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. +C +C REVISIONS +C +C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DHAPVL). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER ILO, INFO, LDA, LDQG, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), CS(*), DWORK(*), QG(LDQG,*), TAU(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ALPHA, C, MU, NU, S, TEMP, TTEMP +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DLARF, DLARFG, DLARTG, DROT, DSYMV, + $ DSYR2, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDWORK.LT.MAX( 1, N-1 ) ) THEN + DWORK(1) = DBLE( MAX( 1, N-1 ) ) + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04PU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.LE.ILO ) THEN + DWORK(1) = ONE + RETURN + END IF +C + DO 10 I = ILO, N-1 +C +C Generate elementary reflector H(i) to annihilate QG(i+2:n,i). +C + ALPHA = QG(I+1,I) + CALL DLARFG( N-I, ALPHA, QG(MIN( I+2,N ),I), 1, NU ) + IF ( NU.NE.ZERO ) THEN + QG(I+1,I) = ONE +C +C Apply H(i) from both sides to QG(i+1:n,i+1:n). +C Compute x := nu * QG(i+1:n,i+1:n) * v. +C + CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, QG(I+1,I), + $ 1, ZERO, DWORK, 1 ) +C +C Compute w := x - 1/2 * nu * (x'*v) * v. +C + MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) + CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) +C +C Apply the transformation as a rank-2 update: +C QG := QG - v * w' - w * v'. +C + CALL DSYR2( 'Lower', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, + $ QG(I+1,I+1), LDQG ) +C +C Apply H(i) from the right hand side to QG(1:i,i+2:n+1). +C + CALL DLARF( 'Right', I, N-I, QG(I+1,I), 1, NU, QG(1,I+2), + $ LDQG, DWORK ) +C +C Apply H(i) from both sides to QG(i+1:n,i+2:n+1). +C Compute x := nu * QG(i+1:n,i+2:n+1) * v. +C + CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, QG(I+1,I), + $ 1, ZERO, DWORK, 1 ) +C +C Compute w := x - 1/2 * nu * (x'*v) * v. +C + MU = -HALF*NU*DDOT( N-I, DWORK, 1, QG(I+1,I), 1 ) + CALL DAXPY( N-I, MU, QG(I+1,I), 1, DWORK, 1 ) +C +C Apply the transformation as a rank-2 update: +C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. +C + CALL DSYR2( 'Upper', N-I, -ONE, QG(I+1,I), 1, DWORK, 1, + $ QG(I+1,I+2), LDQG ) +C +C Apply H(i) from the left hand side to A(i+1:n,i:n). +C + CALL DLARF( 'Left', N-I, N-I+1, QG(I+1,I), 1, NU, + $ A(I+1,I), LDA, DWORK ) +C +C Apply H(i) from the right hand side to A(1:n,i+1:n). +C + CALL DLARF( 'Right', N, N-I, QG(I+1,I), 1, NU, + $ A(1,I+1), LDA, DWORK ) + END IF + QG(I+1,I) = NU +C +C Generate symplectic Givens rotation G(i) to annihilate +C QG(i+1,i). +C + TEMP = A(I+1,I) + CALL DLARTG( TEMP, ALPHA, C, S, A(I+1,I) ) +C +C Apply G(i) to [A(I+1,I+2:N); QG(I+2:N,I+1)']. +C + CALL DROT( N-I-1, A(I+1,I+2), LDA, QG(I+2,I+1), 1, C, S ) +C +C Apply G(i) to [A(1:I,I+1) QG(1:I,I+2)]. +C + CALL DROT(I, A(1,I+1), 1, QG(1,I+2), 1, C, S ) +C +C Apply G(i) to [A(I+2:N,I+1) QG(I+1, I+3:N+1)'] from the right. +C + CALL DROT(N-I-1, A(I+2,I+1), 1, QG(I+1,I+3), LDQG, C, S ) +C +C Fix the diagonal part. +C + TEMP = A(I+1,I+1) + TTEMP = QG(I+1,I+2) + A(I+1,I+1) = C*TEMP + S*QG(I+1,I+1) + QG(I+1,I+2) = C*TTEMP - S * TEMP + QG(I+1,I+1) = -S*TEMP + C*QG(I+1,I+1) + TTEMP = -S*TTEMP - C*TEMP + TEMP = A(I+1,I+1) + QG(I+1,I+1) = C*QG(I+1,I+1) + S*TTEMP + A(I+1,I+1) = C*TEMP + S*QG(I+1,I+2) + QG(I+1,I+2) = -S*TEMP + C*QG(I+1,I+2) + CS(2*I-1) = C + CS(2*I) = S +C +C Generate elementary reflector F(i) to annihilate A(i+2:n,i). +C + CALL DLARFG( N-I, A(I+1,I), A(MIN( I+2,N ),I), 1, NU ) + IF ( NU.NE.ZERO ) THEN + TEMP = A(I+1,I) + A(I+1,I) = ONE +C +C Apply F(i) from the left hand side to A(i+1:n,i+1:n). +C + CALL DLARF( 'Left', N-I, N-I, A(I+1,I), 1, NU, A(I+1,I+1), + $ LDA, DWORK ) +C +C Apply G(i) from the right hand side to A(1:n,i+1:n). +C + CALL DLARF( 'Right', N, N-I, A(I+1,I), 1, NU, + $ A(1,I+1), LDA, DWORK ) +C +C Apply G(i) from both sides to QG(i+1:n,i+1:n). +C Compute x := nu * QG(i+1:n,i+1:n) * v. +C + CALL DSYMV( 'Lower', N-I, NU, QG(I+1,I+1), LDQG, A(I+1,I), + $ 1, ZERO, DWORK, 1 ) +C +C Compute w := x - 1/2 * tau * (x'*v) * v. +C + MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) + CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) +C +C Apply the transformation as a rank-2 update: +C QG := QG - v * w' - w * v'. +C + CALL DSYR2( 'Lower', N-I, -ONE, A(I+1,I), 1, DWORK, 1, + $ QG(I+1,I+1), LDQG ) +C +C Apply G(i) from the right hand side to QG(1:i,i+2:n+1). +C + CALL DLARF( 'Right', I, N-I, A(I+1,I), 1, NU, QG(1,I+2), + $ LDQG, DWORK ) +C +C Apply G(i) from both sides to QG(i+1:n,i+2:n+1). +C Compute x := nu * QG(i+1:n,i+2:n+1) * v. +C + CALL DSYMV( 'Upper', N-I, NU, QG(I+1,I+2), LDQG, A(I+1,I), + $ 1, ZERO, DWORK, 1 ) +C +C Compute w := x - 1/2 * tau * (x'*v) * v. +C + MU = -HALF*NU*DDOT( N-I, DWORK, 1, A(I+1,I), 1 ) + CALL DAXPY( N-I, MU, A(I+1,I), 1, DWORK, 1 ) +C +C Apply the transformation as a rank-2 update: +C QG(i+1:n,i+2:n+1) := QG(i+1:n,i+2:n+1) - v * w' - w * v'. +C + CALL DSYR2( 'Upper', N-I, -ONE, A(I+1,I), 1, DWORK, 1, + $ QG(I+1,I+2), LDQG ) + A(I+1,I) = TEMP + END IF + TAU(I) = NU + 10 CONTINUE + DWORK(1) = DBLE( MAX( 1, N-1 ) ) + RETURN +C *** Last line of MB04PU *** + END diff --git a/mex/sources/libslicot/MB04PY.f b/mex/sources/libslicot/MB04PY.f new file mode 100644 index 000000000..09b5a17d7 --- /dev/null +++ b/mex/sources/libslicot/MB04PY.f @@ -0,0 +1,648 @@ + SUBROUTINE MB04PY( SIDE, M, N, V, TAU, C, LDC, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a real elementary reflector H to a real m-by-n matrix +C C, from either the left or the right. H is represented in the form +C ( 1 ) +C H = I - tau * u *u', u = ( ), +C ( v ) +C where tau is a real scalar and v is a real vector. +C +C If tau = 0, then H is taken to be the unit matrix. +C +C In-line code is used if H has order < 11. +C +C ARGUMENTS +C +C Mode Parameters +C +C SIDE CHARACTER*1 +C Indicates whether the elementary reflector should be +C applied from the left or from the right, as follows: +C = 'L': Compute H * C; +C = 'R': Compute C * H. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix C. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix C. N >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (M-1), if SIDE = 'L', or +C (N-1), if SIDE = 'R'. +C The vector v in the representation of H. +C +C TAU (input) DOUBLE PRECISION +C The scalar factor of the elementary reflector H. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix C. +C On exit, the leading M-by-N part of this array contains +C the matrix H * C, if SIDE = 'L', or C * H, if SIDE = 'R'. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N), if SIDE = 'L', or +C (M), if SIDE = 'R'. +C DWORK is not referenced if H has order less than 11. +C +C METHOD +C +C The routine applies the elementary reflector H, taking its special +C structure into account. The multiplications by the first component +C of u (which is 1) are avoided, to increase the efficiency. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTORS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1999. +C This is a modification of LAPACK Library routine DLARFX. +* +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, elementary reflector, orthogonal +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER SIDE + INTEGER LDC, M, N + DOUBLE PRECISION TAU +C .. +C .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), DWORK( * ), V( * ) +C .. +C .. Local Scalars .. + INTEGER J + DOUBLE PRECISION SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, + $ V1, V2, V3, V4, V5, V6, V7, V8, V9 +C .. +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER +C .. +C .. Executable Statements .. +C + IF( TAU.EQ.ZERO ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +C +C Form H * C, where H has order m. +C + GO TO ( 10, 30, 50, 70, 90, 110, 130, 150, + $ 170, 190 ) M +C +C Code for general M. +C +C w := C'*u. +C + CALL DCOPY( N, C, LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', M-1, N, ONE, C( 2, 1 ), LDC, V, 1, + $ ONE, DWORK, 1 ) +C +C C := C - tau * u * w'. +C + CALL DAXPY( N, -TAU, DWORK, 1, C, LDC ) + CALL DGER( M-1, N, -TAU, V, 1, DWORK, 1, C( 2, 1 ), LDC ) + GO TO 410 + 10 CONTINUE +C +C Special code for 1 x 1 Householder. +C + T1 = ONE - TAU + DO 20 J = 1, N + C( 1, J ) = T1*C( 1, J ) + 20 CONTINUE + GO TO 410 + 30 CONTINUE +C +C Special code for 2 x 2 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + DO 40 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + 40 CONTINUE + GO TO 410 + 50 CONTINUE +C +C Special code for 3 x 3 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 60 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + 60 CONTINUE + GO TO 410 + 70 CONTINUE +C +C Special code for 4 x 4 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 80 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + 80 CONTINUE + GO TO 410 + 90 CONTINUE +C +C Special code for 5 x 5 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 100 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + 100 CONTINUE + GO TO 410 + 110 CONTINUE +C +C Special code for 6 x 6 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 120 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + 120 CONTINUE + GO TO 410 + 130 CONTINUE +C +C Special code for 7 x 7 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 140 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + + $ V6*C( 7, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + C( 7, J ) = C( 7, J ) - SUM*T6 + 140 CONTINUE + GO TO 410 + 150 CONTINUE +C +C Special code for 8 x 8 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 160 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + + $ V6*C( 7, J ) + V7*C( 8, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + C( 7, J ) = C( 7, J ) - SUM*T6 + C( 8, J ) = C( 8, J ) - SUM*T7 + 160 CONTINUE + GO TO 410 + 170 CONTINUE +C +C Special code for 9 x 9 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 180 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + + $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + C( 7, J ) = C( 7, J ) - SUM*T6 + C( 8, J ) = C( 8, J ) - SUM*T7 + C( 9, J ) = C( 9, J ) - SUM*T8 + 180 CONTINUE + GO TO 410 + 190 CONTINUE +C +C Special code for 10 x 10 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 200 J = 1, N + SUM = C( 1, J ) + V1*C( 2, J ) + V2*C( 3, J ) + + $ V3*C( 4, J ) + V4*C( 5, J ) + V5*C( 6, J ) + + $ V6*C( 7, J ) + V7*C( 8, J ) + V8*C( 9, J ) + + $ V9*C( 10, J ) + C( 1, J ) = C( 1, J ) - SUM*TAU + C( 2, J ) = C( 2, J ) - SUM*T1 + C( 3, J ) = C( 3, J ) - SUM*T2 + C( 4, J ) = C( 4, J ) - SUM*T3 + C( 5, J ) = C( 5, J ) - SUM*T4 + C( 6, J ) = C( 6, J ) - SUM*T5 + C( 7, J ) = C( 7, J ) - SUM*T6 + C( 8, J ) = C( 8, J ) - SUM*T7 + C( 9, J ) = C( 9, J ) - SUM*T8 + C( 10, J ) = C( 10, J ) - SUM*T9 + 200 CONTINUE + GO TO 410 + ELSE +C +C Form C * H, where H has order n. +C + GO TO ( 210, 230, 250, 270, 290, 310, 330, 350, + $ 370, 390 ) N +C +C Code for general N. +C +C w := C * u. +C + CALL DCOPY( M, C, 1, DWORK, 1 ) + CALL DGEMV( 'No transpose', M, N-1, ONE, C( 1, 2 ), LDC, V, 1, + $ ONE, DWORK, 1 ) +C +C C := C - tau * w * u'. +C + CALL DAXPY( M, -TAU, DWORK, 1, C, 1 ) + CALL DGER( M, N-1, -TAU, DWORK, 1, V, 1, C( 1, 2 ), LDC ) + GO TO 410 + 210 CONTINUE +C +C Special code for 1 x 1 Householder. +C + T1 = ONE - TAU + DO 220 J = 1, M + C( J, 1 ) = T1*C( J, 1 ) + 220 CONTINUE + GO TO 410 + 230 CONTINUE +C +C Special code for 2 x 2 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + DO 240 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + 240 CONTINUE + GO TO 410 + 250 CONTINUE +C +C Special code for 3 x 3 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + DO 260 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + 260 CONTINUE + GO TO 410 + 270 CONTINUE +C +C Special code for 4 x 4 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + DO 280 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + 280 CONTINUE + GO TO 410 + 290 CONTINUE +C +C Special code for 5 x 5 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + DO 300 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + 300 CONTINUE + GO TO 410 + 310 CONTINUE +C +C Special code for 6 x 6 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + DO 320 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + 320 CONTINUE + GO TO 410 + 330 CONTINUE +C +C Special code for 7 x 7 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + DO 340 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + + $ V6*C( J, 7 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + C( J, 7 ) = C( J, 7 ) - SUM*T6 + 340 CONTINUE + GO TO 410 + 350 CONTINUE +C +C Special code for 8 x 8 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + DO 360 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + + $ V6*C( J, 7 ) + V7*C( J, 8 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + C( J, 7 ) = C( J, 7 ) - SUM*T6 + C( J, 8 ) = C( J, 8 ) - SUM*T7 + 360 CONTINUE + GO TO 410 + 370 CONTINUE +C +C Special code for 9 x 9 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + DO 380 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + + $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + C( J, 7 ) = C( J, 7 ) - SUM*T6 + C( J, 8 ) = C( J, 8 ) - SUM*T7 + C( J, 9 ) = C( J, 9 ) - SUM*T8 + 380 CONTINUE + GO TO 410 + 390 CONTINUE +C +C Special code for 10 x 10 Householder. +C + V1 = V( 1 ) + T1 = TAU*V1 + V2 = V( 2 ) + T2 = TAU*V2 + V3 = V( 3 ) + T3 = TAU*V3 + V4 = V( 4 ) + T4 = TAU*V4 + V5 = V( 5 ) + T5 = TAU*V5 + V6 = V( 6 ) + T6 = TAU*V6 + V7 = V( 7 ) + T7 = TAU*V7 + V8 = V( 8 ) + T8 = TAU*V8 + V9 = V( 9 ) + T9 = TAU*V9 + DO 400 J = 1, M + SUM = C( J, 1 ) + V1*C( J, 2 ) + V2*C( J, 3 ) + + $ V3*C( J, 4 ) + V4*C( J, 5 ) + V5*C( J, 6 ) + + $ V6*C( J, 7 ) + V7*C( J, 8 ) + V8*C( J, 9 ) + + $ V9*C( J, 10 ) + C( J, 1 ) = C( J, 1 ) - SUM*TAU + C( J, 2 ) = C( J, 2 ) - SUM*T1 + C( J, 3 ) = C( J, 3 ) - SUM*T2 + C( J, 4 ) = C( J, 4 ) - SUM*T3 + C( J, 5 ) = C( J, 5 ) - SUM*T4 + C( J, 6 ) = C( J, 6 ) - SUM*T5 + C( J, 7 ) = C( J, 7 ) - SUM*T6 + C( J, 8 ) = C( J, 8 ) - SUM*T7 + C( J, 9 ) = C( J, 9 ) - SUM*T8 + C( J, 10 ) = C( J, 10 ) - SUM*T9 + 400 CONTINUE + GO TO 410 + END IF + 410 CONTINUE + RETURN +C +C *** Last line of MB04PY *** + END diff --git a/mex/sources/libslicot/MB04QB.f b/mex/sources/libslicot/MB04QB.f new file mode 100644 index 000000000..6cb9e6777 --- /dev/null +++ b/mex/sources/libslicot/MB04QB.f @@ -0,0 +1,454 @@ + SUBROUTINE MB04QB( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, + $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To overwrite general real m-by-n matrices C and D, or their +C transposes, with +C +C [ op(C) ] +C Q * [ ] if TRANQ = 'N', or +C [ op(D) ] +C +C T [ op(C) ] +C Q * [ ] if TRANQ = 'T', +C [ op(D) ] +C +C where Q is defined as the product of symplectic reflectors and +C Givens rotators, +C +C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C Blocked version. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANC CHARACTER*1 +C Specifies the form of op( C ) as follows: +C = 'N': op( C ) = C; +C = 'T': op( C ) = C'; +C = 'C': op( C ) = C'. +C +C TRAND CHARACTER*1 +C Specifies the form of op( D ) as follows: +C = 'N': op( D ) = D; +C = 'T': op( D ) = D'; +C = 'C': op( D ) = D'. +C +C TRANQ CHARACTER*1 +C = 'N': apply Q; +C = 'T': apply Q'. +C +C STOREV CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in V are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C STOREW CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in W are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices op(C) and op(D). +C M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices op(C) and op(D). +C N >= 0. +C +C K (input) INTEGER +C The number of elementary reflectors whose product defines +C the matrix Q. M >= K >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (LDV,K) if STOREV = 'C', +C (LDV,M) if STOREV = 'R' +C On entry with STOREV = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflectors F(i). +C On entry with STOREV = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflectors F(i). +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,M), if STOREV = 'C'; +C LDV >= MAX(1,K), if STOREV = 'R'. +C +C W (input) DOUBLE PRECISION array, dimension +C (LDW,K) if STOREW = 'C', +C (LDW,M) if STOREW = 'R' +C On entry with STOREW = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflectors H(i). +C On entry with STOREW = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflectors H(i). +C +C LDW INTEGER +C The leading dimension of the array W. +C LDW >= MAX(1,M), if STOREW = 'C'; +C LDW >= MAX(1,K), if STOREW = 'R'. +C +C C (input/output) DOUBLE PRECISION array, dimension +C (LDC,N) if TRANC = 'N', +C (LDC,M) if TRANC = 'T' or TRANC = 'C' +C On entry with TRANC = 'N', the leading M-by-N part of +C this array must contain the matrix C. +C On entry with TRANC = 'C' or TRANC = 'T', the leading +C N-by-M part of this array must contain the transpose of +C the matrix C. +C On exit with TRANC = 'N', the leading M-by-N part of +C this array contains the updated matrix C. +C On exit with TRANC = 'C' or TRANC = 'T', the leading +C N-by-M part of this array contains the transpose of the +C updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= MAX(1,M), if TRANC = 'N'; +C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,N) if TRAND = 'N', +C (LDD,M) if TRAND = 'T' or TRAND = 'C' +C On entry with TRAND = 'N', the leading M-by-N part of +C this array must contain the matrix D. +C On entry with TRAND = 'C' or TRAND = 'T', the leading +C N-by-M part of this array must contain the transpose of +C the matrix D. +C On exit with TRAND = 'N', the leading M-by-N part of +C this array contains the updated matrix D. +C On exit with TRAND = 'C' or TRAND = 'T', the leading +C N-by-M part of this array contains the transpose of the +C updated matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= MAX(1,M), if TRAND = 'N'; +C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -20, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSB). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ + INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION C(LDC,*), CS(*), D(LDD,*), DWORK(*), TAU(*), + $ V(LDV,*), W(LDW,*) +C .. Local Scalars .. + LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ + INTEGER I, IB, IC, ID, IERR, JC, JD, KI, KK, NB, NBMIN, + $ NX, PDRS, PDT, PDW, WRKOPT +C .. External Functions .. + INTEGER UE01MD + LOGICAL LSAME + EXTERNAL LSAME, UE01MD +C .. External Subroutines .. + EXTERNAL MB04QC, MB04QF, MB04QU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LCOLV = LSAME( STOREV, 'C' ) + LCOLW = LSAME( STOREW, 'C' ) + LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) + LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) + LTRQ = LSAME( TRANQ, 'T' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRC .OR. LSAME( TRANC, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF ( .NOT.( LCOLV .OR. LSAME( STOREV, 'R' ) ) ) THEN + INFO = -4 + ELSE IF ( .NOT.( LCOLW .OR. LSAME( STOREW, 'R' ) ) ) THEN + INFO = -5 + ELSE IF ( M.LT.0 ) THEN + INFO = -6 + ELSE IF ( N.LT.0 ) THEN + INFO = -7 + ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN + INFO = -8 + ELSE IF ( ( LCOLV .AND. LDV.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LCOLV .AND. LDV.LT.MAX( 1, K ) ) ) THEN + INFO = -10 + ELSE IF ( ( LCOLW .AND. LDW.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LCOLW .AND. LDW.LT.MAX( 1, K ) ) ) THEN + INFO = -12 + ELSE IF ( ( LTRC .AND. LDC.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRC .AND. LDC.LT.MAX( 1, M ) ) ) THEN + INFO = -14 + ELSE IF ( ( LTRD .AND. LDD.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRD .AND. LDD.LT.MAX( 1, M ) ) ) THEN + INFO = -16 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -20 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04QB', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( K, M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + NBMIN = 2 + NX = 0 + WRKOPT = N + NB = UE01MD( 1, 'MB04QB', TRANC // TRAND // TRANQ, M, N, K ) + IF ( NB.GT.1 .AND. NB.LT.K ) THEN +C +C Determine when to cross over from blocked to unblocked code. +C + NX = MAX( 0, UE01MD( 3, 'MB04QB', TRANC // TRAND // TRANQ, M, + $ N, K ) ) + IF ( NX.LT.K ) THEN +C +C Determine if workspace is large enough for blocked code. +C + WRKOPT = MAX( WRKOPT, 9*N*NB + 15*NB*NB ) + IF ( LDWORK.LT.WRKOPT ) THEN +C +C Not enough workspace to use optimal NB: reduce NB and +C determine the minimum value of NB. +C + NB = INT( ( SQRT( DBLE( 81*N*N + 60*LDWORK ) ) + $ - DBLE( 9*N ) ) / 30.0D0 ) + NBMIN = MAX( 2, UE01MD( 2, 'MB04QB', TRANC // TRAND // + $ TRANQ, M, N, K ) ) + END IF + END IF + END IF +C + PDRS = 1 + PDT = PDRS + 6*NB*NB + PDW = PDT + 9*NB*NB + IC = 1 + JC = 1 + ID = 1 + JD = 1 +C + IF ( LTRQ ) THEN +C +C Use blocked code initially. +C + IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN + DO 10 I = 1, K - NX, NB + IB = MIN( K-I+1, NB ) +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, + $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), + $ DWORK(PDRS), NB, DWORK(PDT), NB, + $ DWORK(PDW) ) +C +C Apply SH' to [ op(C)(i:m,:); op(D)(i:m,:) ] from the +C left. +C + IF ( LTRC ) THEN + JC = I + ELSE + IC = I + END IF + IF ( LTRD ) THEN + JD = I + ELSE + ID = I + END IF + CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, + $ 'Forward', STOREV, STOREW, M-I+1, N, IB, + $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, + $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), + $ LDD, DWORK(PDW) ) + 10 CONTINUE + ELSE + I = 1 + END IF +C +C Use unblocked code to update last or only block. +C + IF ( I.LE.K ) THEN + IF ( LTRC ) THEN + JC = I + ELSE + IC = I + END IF + IF ( LTRD ) THEN + JD = I + ELSE + ID = I + END IF + CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-I+1, N, + $ K-I+1, V(I,I), LDV, W(I,I), LDW, C(IC,JC), LDC, + $ D(ID,JD), LDD, CS(2*I-1), TAU(I), DWORK, + $ LDWORK, IERR ) + END IF + ELSE + IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +C +C Use blocked code after the last block. +C The first kk columns are handled by the block method. +C + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) + ELSE + KK = 0 + END IF +C +C Use unblocked code for the last or only block. +C + IF ( KK.LT.K ) THEN + IF ( LTRC ) THEN + JC = KK + 1 + ELSE + IC = KK + 1 + END IF + IF ( LTRD ) THEN + JD = KK + 1 + ELSE + ID = KK + 1 + END IF + CALL MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M-KK, N, + $ K-KK, V(KK+1,KK+1), LDV, W(KK+1,KK+1), LDW, + $ C(IC,JC), LDC, D(ID,JD), LDD, CS(2*KK+1), + $ TAU(KK+1), DWORK, LDWORK, IERR ) + END IF +C +C Blocked code. +C + IF ( KK.GT.0 ) THEN + DO 20 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', STOREV, STOREW, M-I+1, IB, + $ V(I,I), LDV, W(I,I), LDW, CS(2*I-1), TAU(I), + $ DWORK(PDRS), NB, DWORK(PDT), NB, + $ DWORK(PDW) ) +C +C Apply SH to [ op(C)(i:m,:); op(D)(i:m,:) ] from +C the left. +C + IF ( LTRC ) THEN + JC = I + ELSE + IC = I + END IF + IF ( LTRD ) THEN + JD = I + ELSE + ID = I + END IF + CALL MB04QC( 'No Structure', TRANC, TRAND, TRANQ, + $ 'Forward', STOREV, STOREW, M-I+1, N, IB, + $ V(I,I), LDV, W(I,I), LDW, DWORK(PDRS), NB, + $ DWORK(PDT), NB, C(IC,JC), LDC, D(ID,JD), + $ LDD, DWORK(PDW) ) + 20 CONTINUE + END IF + END IF + DWORK(1) = DBLE( WRKOPT ) +C + RETURN +C *** Last line of MB04QB *** + END diff --git a/mex/sources/libslicot/MB04QC.f b/mex/sources/libslicot/MB04QC.f new file mode 100644 index 000000000..44d6a9ebd --- /dev/null +++ b/mex/sources/libslicot/MB04QC.f @@ -0,0 +1,1223 @@ + SUBROUTINE MB04QC( STRUCT, TRANA, TRANB, TRANQ, DIRECT, STOREV, + $ STOREW, M, N, K, V, LDV, W, LDW, RS, LDRS, T, + $ LDT, A, LDA, B, LDB, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the orthogonal symplectic block reflector +C +C [ I+V*T*V' V*R*S*V' ] +C Q = [ ] +C [ -V*R*S*V' I+V*T*V' ] +C +C or its transpose to a real 2m-by-n matrix [ op(A); op(B) ] from +C the left. +C The k-by-k upper triangular blocks of the matrices +C +C [ S1 ] [ T11 T12 T13 ] +C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], +C [ S3 ] [ T31 T32 T33 ] +C +C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, +C are stored rowwise in the arrays RS and T, respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C STRUCT CHARACTER*1 +C Specifies the structure of the first blocks of A and B: +C = 'Z': the leading K-by-N submatrices of op(A) and op(B) +C are (implicitly) assumed to be zero; +C = 'N'; no structure to mention. +C +C TRANA CHARACTER*1 +C Specifies the form of op( A ) as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op( B ) as follows: +C = 'N': op( B ) = B; +C = 'T': op( B ) = B'; +C = 'C': op( B ) = B'. +C +C DIRECT CHARACTER*1 +C This is a dummy argument, which is reserved for future +C extensions of this subroutine. Not referenced. +C +C TRANQ CHARACTER*1 +C = 'N': apply Q; +C = 'T': apply Q'. +C +C STOREV CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in V are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C STOREW CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in W are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices op(A) and op(B). +C M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices op(A) and op(B). +C N >= 0. +C +C K (input) INTEGER +C The order of the triangular matrices defining R, S and T. +C M >= K >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (LDV,K) if STOREV = 'C', +C (LDV,M) if STOREV = 'R' +C On entry with STOREV = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflector used to form parts of Q. +C On entry with STOREV = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflector used to form parts of Q. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,M), if STOREV = 'C'; +C LDV >= MAX(1,K), if STOREV = 'R'. +C +C W (input) DOUBLE PRECISION array, dimension +C (LDW,K) if STOREW = 'C', +C (LDW,M) if STOREW = 'R' +C On entry with STOREW = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflector used to form parts of Q. +C On entry with STOREW = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflector used to form parts of Q. +C +C LDW INTEGER +C The leading dimension of the array W. +C LDW >= MAX(1,M), if STOREW = 'C'; +C LDW >= MAX(1,K), if STOREW = 'R'. +C +C RS (input) DOUBLE PRECISION array, dimension (K,6*K) +C On entry, the leading K-by-6*K part of this array must +C contain the upper triangular matrices defining the factors +C R and S of the symplectic block reflector Q. The +C (strictly) lower portions of this array are not +C referenced. +C +C LDRS INTEGER +C The leading dimension of the array RS. LDRS >= MAX(1,K). +C +C T (input) DOUBLE PRECISION array, dimension (K,9*K) +C On entry, the leading K-by-9*K part of this array must +C contain the upper triangular matrices defining the factor +C T of the symplectic block reflector Q. The (strictly) +C lower portions of this array are not referenced. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,K). +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,N) if TRANA = 'N', +C (LDA,M) if TRANA = 'C' or TRANA = 'T' +C On entry with TRANA = 'N', the leading M-by-N part of this +C array must contain the matrix A. +C On entry with TRANA = 'T' or TRANA = 'C', the leading +C N-by-M part of this array must contain the matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,M), if TRANA = 'N'; +C LDA >= MAX(1,N), if TRANA = 'C' or TRANA = 'T'. +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,N) if TRANB = 'N', +C (LDB,M) if TRANB = 'C' or TRANB = 'T' +C On entry with TRANB = 'N', the leading M-by-N part of this +C array must contain the matrix B. +C On entry with TRANB = 'T' or TRANB = 'C', the leading +C N-by-M part of this array must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,M), if TRANB = 'N'; +C LDB >= MAX(1,N), if TRANB = 'C' or TRANB = 'T'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK), where +C LDWORK >= 8*N*K, if STRUCT = 'Z', +C LDWORK >= 9*N*K, if STRUCT = 'N'. +C +C REFERENCES +C +C [1] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 16*( M - K )*N + ( 26*K - 4 )*K*N floating +C point operations if STRUCT = 'Z' and additional ( 12*K + 2 )*K*N +C floating point operations if STRUCT = 'N'. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAESB). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DIRECT, STOREV, STOREW, STRUCT, TRANA, TRANB, + $ TRANQ + INTEGER K, LDA, LDB, LDRS, LDT, LDV, LDW, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), RS(LDRS,*), + $ T(LDT,*), V(LDV,*), W(LDW,*) +C .. Local Scalars .. + LOGICAL LA1B1, LCOLV, LCOLW, LTRA, LTRB, LTRQ + INTEGER I, ITEMP, PDW1, PDW2, PDW3, PDW4, PDW5, PDW6, + $ PDW7, PDW8, PDW9, PR1, PR2, PR3, PS1, PS2, PS3, + $ PT11, PT12, PT13, PT21, PT22, PT23, PT31, PT32, + $ PT33 + DOUBLE PRECISION FACT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DLASET, DTRMM +C +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN + LA1B1 = LSAME( STRUCT, 'N' ) + LCOLV = LSAME( STOREV, 'C' ) + LCOLW = LSAME( STOREW, 'C' ) + LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + LTRQ = LSAME( TRANQ, 'T' ) .OR. LSAME( TRANQ, 'C' ) +C + PR1 = 1 + PR2 = PR1 + K + PR3 = PR2 + K + PS1 = PR3 + K + PS2 = PS1 + K + PS3 = PS2 + K + PT11 = 1 + PT12 = PT11 + K + PT13 = PT12 + K + PT21 = PT13 + K + PT22 = PT21 + K + PT23 = PT22 + K + PT31 = PT23 + K + PT32 = PT31 + K + PT33 = PT32 + K + PDW1 = 1 + PDW2 = PDW1 + N*K + PDW3 = PDW2 + N*K + PDW4 = PDW3 + N*K + PDW5 = PDW4 + N*K + PDW6 = PDW5 + N*K + PDW7 = PDW6 + N*K + PDW8 = PDW7 + N*K + PDW9 = PDW8 + N*K +C +C Update the matrix A. +C + IF ( LA1B1 ) THEN +C +C NZ1) DW7 := A1' +C + IF ( LTRA ) THEN + DO 10 I = 1, K + CALL DCOPY( N, A(1,I), 1, DWORK(PDW7+(I-1)*N), 1 ) + 10 CONTINUE + ELSE + DO 20 I = 1, N + CALL DCOPY( K, A(1,I), 1, DWORK(PDW7+I-1), N ) + 20 CONTINUE + END IF +C +C NZ2) DW1 := DW7*W1 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW1), 1 ) + IF ( LCOLW ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, W, LDW, DWORK(PDW1), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, + $ K, ONE, W, LDW, DWORK(PDW1), N ) + END IF +C +C NZ3) DW2 := DW7*V1 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW2), 1 ) + IF ( LCOLV ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, DWORK(PDW2), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, + $ K, ONE, V, LDV, DWORK(PDW2), N ) + END IF + FACT = ONE + ELSE + FACT = ZERO + END IF +C +C 1) DW1 := A2'*W2 +C + IF ( M.GT.K ) THEN + IF ( LTRA.AND.LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, + $ A(1,K+1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE IF ( LTRA ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, + $ A(1,K+1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE IF ( LCOLW ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, + $ A(K+1,1), LDA, W(K+1,1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ A(K+1,1), LDA, W(1,K+1), LDW, FACT, DWORK(PDW1), + $ N ) + END IF + ELSE IF ( .NOT.LA1B1 ) THEN + CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) + END IF +C +C 2) DW2 := A2'*V2 +C + IF ( M.GT.K ) THEN + IF ( LTRA.AND.LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, + $ A(1,K+1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), + $ N ) + ELSE IF ( LTRA ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, + $ A(1,K+1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), + $ N ) + ELSE IF ( LCOLV ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, + $ A(K+1,1), LDA, V(K+1,1), LDV, FACT, DWORK(PDW2), + $ N ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ A(K+1,1), LDA, V(1,K+1), LDV, FACT, DWORK(PDW2), + $ N ) + END IF + ELSE IF ( .NOT.LA1B1 ) THEN + CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW2), N ) + END IF +C + IF ( LTRQ ) THEN +C +C 3) DW3 := DW1*T11 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) +C +C 4) DW4 := DW2*T31 +C + CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) +C +C 5) DW3 := DW3 + DW4 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ4) DW8 := DW7*T21 +C + CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) +C +C NZ5) DW3 := DW3 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) + END IF +C +C 6) DW4 := DW1*T12 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT12), LDT, DWORK(PDW4), N ) +C +C 7) DW5 := DW2*T32 +C + CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) +C +C 8) DW4 := DW4 + DW5 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ6) DW8 := DW7*T22 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) +C +C NZ7) DW4 := DW4 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) + END IF +C +C 9) DW5 := DW2*T33 +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) +C +C 10) DW6 := DW1*T13 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW6), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT13), LDT, DWORK(PDW6), N ) +C +C 11) DW5 := DW5 + DW6 +C + CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ8) DW8 := DW7*T23 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT23), LDT, DWORK(PDW8), N ) +C +C NZ9) DW5 := DW5 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) + END IF +C +C 12) DW1 := DW1*R1 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PR1), LDRS, DWORK(PDW1), N ) +C +C 13) DW2 := DW2*R3 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW2), N ) +C +C 14) DW1 := DW1 + DW2 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW2), 1, DWORK(PDW1+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ10) DW7 := DW7*R2 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) +C +C NZ11) DW1 := DW1 + DW7 +C + CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW1), 1 ) + END IF +C +C Swap Pointers PDW1 <-> PDW2 +C + ITEMP = PDW2 + PDW2 = PDW1 + PDW1 = ITEMP + ELSE +C +C 3) DW3 := DW1*T11' +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) +C +C 4) DW4 := DW2*T13' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) +C +C 5) DW3 := DW3 + DW4 +C + CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ4) DW8 := DW7*T12' +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) +C +C NZ5) DW3 := DW3 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) + END IF +C +C 6) DW4 := DW2*T23' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) +C +C 7) DW5 := DW1*T21' +C + CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) +C +C 8) DW4 := DW4 + DW5 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ6) DW8 := DW7*T22' +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) +C +C NZ7) DW4 := DW4 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) + END IF +C +C 9) DW5 := DW2*T33' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT33), LDT, DWORK(PDW5), N ) +C +C 10) DW6 := DW1*T31' +C + CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, T(1,PT31+1), LDT, DWORK(PDW6), N ) +C +C 11) DW5 := DW5 + DW6 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW6), 1, DWORK(PDW5), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ8) DW8 := DW7*T32' +C + CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW8), N ) +C +C NZ9) DW5 := DW5 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) + END IF +C +C 12) DW1 := DW1*S1' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW1+N), N ) +C +C 13) DW2 := DW2*S3' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) +C +C 14) DW2 := DW1 + DW2 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW2), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ10) DW7 := DW7*S2' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) +C +C NZ11) DW2 := DW2 + DW7 +C + CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW2), 1 ) + END IF + END IF +C + IF ( LA1B1 ) THEN +C +C NZ12) DW9 := B1' +C + IF ( LTRB ) THEN + DO 30 I = 1, K + CALL DCOPY( N, B(1,I), 1, DWORK(PDW9+(I-1)*N), 1 ) + 30 CONTINUE + ELSE + DO 40 I = 1, N + CALL DCOPY( K, B(1,I), 1, DWORK(PDW9+I-1), N ) + 40 CONTINUE + END IF +C +C NZ13) DW1 := DW9*W1 +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW1), 1 ) + IF ( LCOLW ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, W, LDW, DWORK(PDW1), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, + $ K, ONE, W, LDW, DWORK(PDW1), N ) + END IF +C +C NZ14) DW6 := DW9*V1 +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW6), 1 ) + IF ( LCOLV ) THEN + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, DWORK(PDW6), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, + $ K, ONE, V, LDV, DWORK(PDW6), N ) + END IF + END IF +C +C 15) DW1 := B2'*W2 +C + IF ( M.GT.K ) THEN + IF ( LTRB.AND.LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, + $ B(1,K+1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE IF ( LTRB ) THEN +C +C Critical Position +C + CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, + $ B(1,K+1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE IF ( LCOLW ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, + $ B(K+1,1), LDB, W(K+1,1), LDW, FACT, DWORK(PDW1), + $ N ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ B(K+1,1), LDB, W(1,K+1), LDW, FACT, DWORK(PDW1), + $ N ) + END IF + ELSE IF ( .NOT.LA1B1 ) THEN + CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW1), N ) + END IF +C +C 16) DW6 := B2'*V2 +C + IF ( M.GT.K ) THEN + IF ( LTRB.AND.LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, K, M-K, ONE, + $ B(1,K+1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), + $ N ) + ELSE IF ( LTRB ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, K, M-K, ONE, + $ B(1,K+1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), + $ N ) + ELSE IF ( LCOLV ) THEN + CALL DGEMM( 'Transpose', 'No Transpose', N, K, M-K, ONE, + $ B(K+1,1), LDB, V(K+1,1), LDV, FACT, DWORK(PDW6), + $ N ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ B(K+1,1), LDB, V(1,K+1), LDV, FACT, DWORK(PDW6), + $ N ) + END IF + ELSE IF ( .NOT.LA1B1 ) THEN + CALL DLASET( 'All', N, K, ZERO, ZERO, DWORK(PDW6), N ) + END IF +C + IF ( LTRQ ) THEN +C +C 17) DW7 := DW1*R1 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW7), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PR1), LDRS, DWORK(PDW7), N ) +C +C 18) DW8 := DW6*R3 +C + CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) +C +C 19) DW7 := DW7 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ15) DW8 := DW9*R2 +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, RS(1,PR2), LDRS, DWORK(PDW8), N ) +C +C NZ16) DW7 := DW7 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) + END IF +C +C 20) DW8 := DW7*S1 +C + CALL DCOPY( N*(K-1), DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) +C +C 21) DW3 := DW3 - DW8 +C + CALL DAXPY( N*(K-1), -ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) +C +C 22) DW8 := DW7*S3 +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, RS(1,PS3), LDRS, DWORK(PDW8), N ) +C +C 23) DW5 := DW5 - DW8 +C + CALL DAXPY( N*K, -ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) +C +C 24) DW7 := DW7*S2 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ -ONE, RS(1,PS2), LDRS, DWORK(PDW7), N ) + ELSE +C +C 17) DW7 := DW6*S3' +C + CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW7), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS3), LDRS, DWORK(PDW7), N ) +C +C 18) DW8 := DW1*S1' +C + CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, RS(1,PS1+1), LDRS, DWORK(PDW8), N ) +C +C 19) DW7 := DW7 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ15) DW8 := DW9*S2' +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS2), LDRS, DWORK(PDW8), N ) +C +C NZ16) DW7 := DW7 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW7), 1 ) + END IF +C +C 20) DW8 := DW7*R1' +C + CALL DCOPY( N*K, DWORK(PDW7), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PR1), LDRS, DWORK(PDW8), N ) +C +C 21) DW3 := DW3 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) +C +C 22) DW8 := DW7*R3' +C + CALL DCOPY( N*(K-1), DWORK(PDW7+N), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW8), N ) +C +C 23) DW5 := DW5 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW5), 1 ) +C +C 24) DW7 := DW7*R2' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, RS(1,PR2), LDRS, DWORK(PDW7), N ) + END IF +C +C 25) A2 := A2 + W2*DW3' +C + IF ( M.GT.K ) THEN + IF ( LTRA.AND.LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, + $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, A(1,K+1), + $ LDA ) + ELSE IF ( LTRA ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, + $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, A(1,K+1), + $ LDA ) + ELSE IF ( LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, + $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), + $ LDA ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, + $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, A(K+1,1), + $ LDA ) + END IF + END IF +C +C 26) A2 := A2 + V2*DW5' +C + IF ( M.GT.K ) THEN + IF ( LTRA.AND.LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, + $ DWORK(PDW5), N, V(K+1,1), LDV, ONE, A(1,K+1), + $ LDA ) + ELSE IF ( LTRA ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, + $ DWORK(PDW5), N, V(1,K+1), LDV, ONE, A(1,K+1), + $ LDA ) + ELSE IF ( LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, + $ V(K+1,1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), + $ LDA ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, + $ V(1,K+1), LDV, DWORK(PDW5), N, ONE, A(K+1,1), + $ LDA ) + END IF + END IF +C +C 27) DW4 := DW4 + DW7 +C + CALL DAXPY( N*K, ONE, DWORK(PDW7), 1, DWORK(PDW4), 1 ) +C +C 28) DW3 := DW3*W1' +C + IF ( LCOLW ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, + $ W, LDW, DWORK(PDW3), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, W, LDW, DWORK(PDW3), N ) + END IF +C +C 29) DW4 := DW4 + DW3 +C + CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) +C +C 30) DW5 := DW5*V1' +C + IF ( LCOLV ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, + $ V, LDV, DWORK(PDW5), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, V, LDV, DWORK(PDW5), N ) + END IF +C +C 31) DW4 := DW4 + DW5 +C + CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C +C 32) A1 := A1 + DW4' +C + IF ( LA1B1 ) THEN + IF ( LTRA ) THEN + DO 50 I = 1, K + CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) + 50 CONTINUE + ELSE + DO 60 I = 1, N + CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, A(1,I), 1 ) + 60 CONTINUE + END IF + ELSE + IF ( LTRA ) THEN + DO 70 I = 1, K + CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, A(1,I), 1 ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + CALL DCOPY( K, DWORK(PDW4+I-1), N, A(1,I), 1 ) + 80 CONTINUE + END IF + END IF +C +C Update the matrix B. +C + IF ( LTRQ ) THEN +C +C 33) DW3 := DW1*T11 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) +C +C 34) DW4 := DW6*T31 +C + CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT31+1), LDT, DWORK(PDW4), N ) +C +C 35) DW3 := DW3 + DW4 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ17) DW8 := DW9*T21 +C + CALL DCOPY( N*(K-1), DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT21+1), LDT, DWORK(PDW8), N ) +C +C NZ18) DW3 := DW3 + DW8 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW8), 1, DWORK(PDW3+N), 1 ) + END IF +C +C 36) DW4 := DW2*S1 +C + CALL DCOPY( N*(K-1), DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, RS(1,PS1+1), LDRS, DWORK(PDW4), N ) +C +C 37) DW3 := DW3 + DW4 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW4), 1, DWORK(PDW3+N), 1 ) +C +C 38) DW4 := DW1*T12 +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT12), LDT, DWORK(PDW4), N ) +C +C 38) DW5 := DW6*T32 +C + CALL DCOPY( N*(K-1), DWORK(PDW6), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW5), N ) +C +C 40) DW4 := DW4 + DW5 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4+N), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ19) DW8 := DW9*T22 +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT22), LDT, DWORK(PDW8), N ) +C +C NZ20) DW4 := DW4 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) + END IF +C +C 41) DW5 := DW2*S2 +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS2), LDRS, DWORK(PDW5), N ) +C +C 42) DW4 := DW4 + DW5 +C + CALL DAXPY( N*K, ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C +C 43) DW6 := DW6*T33 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) +C +C 44) DW1 := DW1*T13 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT13), LDT, DWORK(PDW1), N ) +C +C 45) DW6 := DW6 + DW1 +C + CALL DAXPY( N*K, ONE, DWORK(PDW1), 1, DWORK(PDW6), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ19) DW9 := DW9*T23 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, + $ K, ONE, T(1,PT23), LDT, DWORK(PDW9), N ) +C +C NZ20) DW6 := DW6 + DW9 +C + CALL DAXPY( N*K, ONE, DWORK(PDW9), 1, DWORK(PDW6), 1 ) + END IF +C +C 46) DW2 := DW2*S3 +C + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PS3), LDRS, DWORK(PDW2), N ) +C +C 45) DW6 := DW6 + DW2 +C + CALL DAXPY( N*K, ONE, DWORK(PDW2), 1, DWORK(PDW6), 1 ) + ELSE +C +C 33) DW3 := DW1*T11' +C + CALL DCOPY( N*K, DWORK(PDW1), 1, DWORK(PDW3), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT11), LDT, DWORK(PDW3), N ) +C +C 34) DW4 := DW6*T13' +C + CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT13), LDT, DWORK(PDW4), N ) +C +C 35) DW3 := DW3 + DW4 +C + CALL DAXPY( N*K, ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ17) DW8 := DW9*T12' +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT12), LDT, DWORK(PDW8), N ) +C +C NZ18) DW3 := DW3 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW3), 1 ) + END IF +C +C 36) DW4 := DW2*R1' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, RS(1,PR1), LDRS, DWORK(PDW4), N ) +C +C 37) DW3 := DW3 - DW4 +C + CALL DAXPY( N*K, -ONE, DWORK(PDW4), 1, DWORK(PDW3), 1 ) +C +C 38) DW4 := DW6*T23' +C + CALL DCOPY( N*K, DWORK(PDW6), 1, DWORK(PDW4), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT23), LDT, DWORK(PDW4), N ) +C +C 39) DW5 := DW1*T21' +C + CALL DCOPY( N*(K-1), DWORK(PDW1+N), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, T(1,PT21+1), LDT, DWORK(PDW5), N ) +C +C 40) DW4 := DW4 + DW5 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ19) DW8 := DW9*T22' +C + CALL DCOPY( N*K, DWORK(PDW9), 1, DWORK(PDW8), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT22), LDT, DWORK(PDW8), N ) +C +C NZ20) DW4 := DW4 + DW8 +C + CALL DAXPY( N*K, ONE, DWORK(PDW8), 1, DWORK(PDW4), 1 ) + END IF +C +C 41) DW5 := DW2*R2' +C + CALL DCOPY( N*K, DWORK(PDW2), 1, DWORK(PDW5), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, RS(1,PR2), LDRS, DWORK(PDW5), N ) +C +C 42) DW4 := DW4 - DW5 +C + CALL DAXPY( N*K, -ONE, DWORK(PDW5), 1, DWORK(PDW4), 1 ) +C +C 43) DW6 := DW6*T33' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K, + $ ONE, T(1,PT33), LDT, DWORK(PDW6), N ) +C +C 44) DW1 := DW1*T31' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, T(1,PT31+1), LDT, DWORK(PDW1+N), N ) +C +C 45) DW6 := DW6 + DW1 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW1+N), 1, DWORK(PDW6), 1 ) +C + IF ( LA1B1 ) THEN +C +C NZ19) DW9 := DW9*T32' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, + $ K-1, ONE, T(1,PT32+1), LDT, DWORK(PDW9+N), N ) +C +C NZ20) DW6 := DW6 + DW9 +C + CALL DAXPY( N*(K-1), ONE, DWORK(PDW9+N), 1, DWORK(PDW6), 1 ) + END IF +C +C 46) DW2 := DW2*R3' +C + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-Unit', N, K-1, + $ ONE, RS(1,PR3+1), LDRS, DWORK(PDW2+N), N ) +C +C 45) DW6 := DW6 - DW2 +C + CALL DAXPY( N*(K-1), -ONE, DWORK(PDW2+N), 1, DWORK(PDW6), 1 ) + END IF +C +C 46) B2 := B2 + W2*DW3' +C + IF ( M.GT.K ) THEN + IF ( LTRB.AND.LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, + $ DWORK(PDW3), N, W(K+1,1), LDW, ONE, B(1,K+1), + $ LDB ) + ELSE IF ( LTRB ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, + $ DWORK(PDW3), N, W(1,K+1), LDW, ONE, B(1,K+1), + $ LDB ) + ELSE IF ( LCOLW ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, + $ W(K+1,1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), + $ LDB ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, + $ W(1,K+1), LDW, DWORK(PDW3), N, ONE, B(K+1,1), + $ LDB ) + END IF + END IF +C +C 47) B2 := B2 + V2*DW6' +C + IF ( M.GT.K ) THEN + IF ( LTRB.AND.LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', N, M-K, K, ONE, + $ DWORK(PDW6), N, V(K+1,1), LDV, ONE, B(1,K+1), + $ LDB ) + ELSE IF ( LTRB ) THEN + CALL DGEMM( 'No Transpose', 'No Transpose', N, M-K, K, ONE, + $ DWORK(PDW6), N, V(1,K+1), LDV, ONE, B(1,K+1), + $ LDB ) + ELSE IF ( LCOLV ) THEN + CALL DGEMM( 'No Transpose', 'Transpose', M-K, N, K, ONE, + $ V(K+1,1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), + $ LDB ) + ELSE + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, ONE, + $ V(1,K+1), LDV, DWORK(PDW6), N, ONE, B(K+1,1), + $ LDB ) + END IF + END IF +C +C 48) DW3 := DW3*W1' +C + IF ( LCOLW ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, + $ W, LDW, DWORK(PDW3), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, W, LDW, DWORK(PDW3), N ) + END IF +C +C 49) DW4 := DW4 + DW3 +C + CALL DAXPY( N*K, ONE, DWORK(PDW3), 1, DWORK(PDW4), 1 ) +C +C 50) DW6 := DW6*V1' +C + IF ( LCOLV ) THEN + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, ONE, + $ V, LDV, DWORK(PDW6), N ) + ELSE + CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Unit', N, K, + $ ONE, V, LDV, DWORK(PDW6), N ) + END IF +C +C 51) DW4 := DW4 + DW6 +C + CALL DAXPY( N*K, ONE, DWORK(PDW6), 1, DWORK(PDW4), 1 ) +C +C 52) B1 := B1 + DW4' +C + IF ( LA1B1 ) THEN + IF ( LTRB ) THEN + DO 90 I = 1, K + CALL DAXPY( N, ONE, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) + 90 CONTINUE + ELSE + DO 100 I = 1, N + CALL DAXPY( K, ONE, DWORK(PDW4+I-1), N, B(1,I), 1 ) + 100 CONTINUE + END IF + ELSE + IF ( LTRB ) THEN + DO 110 I = 1, K + CALL DCOPY( N, DWORK(PDW4+(I-1)*N), 1, B(1,I), 1 ) + 110 CONTINUE + ELSE + DO 120 I = 1, N + CALL DCOPY( K, DWORK(PDW4+I-1), N, B(1,I), 1 ) + 120 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of MB04QC *** + END diff --git a/mex/sources/libslicot/MB04QF.f b/mex/sources/libslicot/MB04QF.f new file mode 100644 index 000000000..f2be26ce0 --- /dev/null +++ b/mex/sources/libslicot/MB04QF.f @@ -0,0 +1,532 @@ + SUBROUTINE MB04QF( DIRECT, STOREV, STOREW, N, K, V, LDV, W, LDW, + $ CS, TAU, RS, LDRS, T, LDT, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To form the triangular block factors R, S and T of a symplectic +C block reflector SH, which is defined as a product of 2k +C concatenated Householder reflectors and k Givens rotators, +C +C SH = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C The upper triangular blocks of the matrices +C +C [ S1 ] [ T11 T12 T13 ] +C R = [ R1 R2 R3 ], S = [ S2 ], T = [ T21 T22 T23 ], +C [ S3 ] [ T31 T32 T33 ] +C +C with R2 unit and S1, R3, T21, T31, T32 strictly upper triangular, +C are stored rowwise in the arrays RS and T, respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C DIRECT CHARACTER*1 +C This is a dummy argument, which is reserved for future +C extensions of this subroutine. Not referenced. +C +C STOREV CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder F(i) reflectors are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C STOREW CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder H(i) reflectors are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the Householder reflectors F(i) and H(i). +C N >= 0. +C +C K (input) INTEGER +C The number of Givens rotators. K >= 1. +C +C V (input) DOUBLE PRECISION array, dimension +C (LDV,K) if STOREV = 'C', +C (LDV,N) if STOREV = 'R' +C On entry with STOREV = 'C', the leading N-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector F(i). +C On entry with STOREV = 'R', the leading K-by-N part of +C this array must contain in its i-th row the vector +C which defines the elementary reflector F(i). +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,N), if STOREV = 'C'; +C LDV >= K, if STOREV = 'R'. +C +C W (input) DOUBLE PRECISION array, dimension +C (LDW,K) if STOREW = 'C', +C (LDW,N) if STOREW = 'R' +C On entry with STOREW = 'C', the leading N-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector H(i). +C On entry with STOREV = 'R', the leading K-by-N part of +C this array must contain in its i-th row the vector +C which defines the elementary reflector H(i). +C +C LDW INTEGER +C The leading dimension of the array W. +C LDW >= MAX(1,N), if STOREW = 'C'; +C LDW >= K, if STOREW = 'R'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C RS (output) DOUBLE PRECISION array, dimension (K,6*K) +C On exit, the leading K-by-6*K part of this array contains +C the upper triangular matrices defining the factors R and +C S of the symplectic block reflector SH. The (strictly) +C lower portions of this array are not used. +C +C LDRS INTEGER +C The leading dimension of the array RS. LDRS >= K. +C +C T (output) DOUBLE PRECISION array, dimension (K,9*K) +C On exit, the leading K-by-9*K part of this array contains +C the upper triangular matrices defining the factor T of the +C symplectic block reflector SH. The (strictly) lower +C portions of this array are not used. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= K. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*K) +C +C REFERENCES +C +C [1] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C NUMERICAL ASPECTS +C +C The algorithm requires ( 4*K - 2 )*K*N + 19/3*K*K*K + 1/2*K*K +C + 43/6*K - 4 floating point operations. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DLAEST). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DIRECT, STOREV, STOREW + INTEGER K, LDRS, LDT, LDV, LDW, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), RS(LDRS,*), T(LDT,*), + $ TAU(*), V(LDV,*), W(LDW,*) +C .. Local Scalars .. + LOGICAL LCOLV, LCOLW + INTEGER I, J, K2, PR1, PR2, PR3, PS1, PS2, PS3, PT11, + $ PT12, PT13, PT21, PT22, PT23, PT31, PT32, PT33 + DOUBLE PRECISION CM1, TAUI, VII, WII +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DSCAL, DTRMV +C +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + LCOLV = LSAME( STOREV, 'C' ) + LCOLW = LSAME( STOREW, 'C' ) +C + K2 = K + K + PR1 = 0 + PR2 = PR1 + K + PR3 = PR2 + K + PS1 = PR3 + K + PS2 = PS1 + K + PS3 = PS2 + K +C + PT11 = 0 + PT12 = PT11 + K + PT13 = PT12 + K + PT21 = PT13 + K + PT22 = PT21 + K + PT23 = PT22 + K + PT31 = PT23 + K + PT32 = PT31 + K + PT33 = PT32 + K +C + DO 90 I = 1, K + TAUI = TAU(I) + VII = V(I,I) + V(I,I) = ONE + WII = W(I,I) + W(I,I) = ONE + IF ( WII.EQ.ZERO ) THEN + DO 10 J = 1, I + T(J,PT11+I) = ZERO + 10 CONTINUE + DO 20 J = 1, I-1 + T(J,PT21+I) = ZERO + 20 CONTINUE + DO 30 J = 1, I-1 + T(J,PT31+I) = ZERO + 30 CONTINUE + DO 40 J = 1, I-1 + RS(J,PS1+I) = ZERO + 40 CONTINUE + ELSE +C +C Treat first Householder reflection. +C + IF ( LCOLV.AND.LCOLW ) THEN +C +C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, + $ W(I,I), 1, ZERO, DWORK, 1 ) +C +C Compute t2 = -wii * V(i:n,1:i-1)' * W(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, + $ W(I,I), 1, ZERO, DWORK(K+1), 1 ) + ELSE IF ( LCOLV ) THEN +C +C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), + $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) +C +C Compute t2 = -wii * V(i:n,1:i-1)' * W(i,i:n)'. +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, V(I,1), LDV, + $ W(I,I), LDW, ZERO, DWORK(K+1), 1 ) + ELSE IF ( LCOLW ) THEN +C +C Compute t1 = -wii * W(i:n,1:i-1)' * W(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -WII, W(I,1), LDW, + $ W(I,I), 1, ZERO, DWORK, 1 ) +C +C Compute t2 = -wii * V(1:i-1,i:n) * W(i:n,i). +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), + $ LDV, W(I,I), 1, ZERO, DWORK(K+1), 1 ) + ELSE +C +C Compute t1 = -wii * W(1:i-1,i:n) * W(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, W(1,I), + $ LDW, W(I,I), LDW, ZERO, DWORK, 1 ) +C +C Compute t2 = -wii * V(1:i-1,i:n) * W(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -WII, V(1,I), + $ LDV, W(I,I), LDW, ZERO, DWORK(K+1), 1 ) + END IF +C +C T11(1:i-1,i) := T11(1:i-1,1:i-1)*t1 + T13(1:i-1,1:i-1)*t2 +C + CALL DCOPY( I-1, DWORK, 1, T(1,PT11+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT11+1), LDT, T(1,PT11+I), 1 ) + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, T(1,PT11+I), 1 ) + T(I,PT11+I) = -WII +C + IF ( I.GT.1 ) THEN +C +C T21(1:i-1,i) := T21(1:i-1,1:i-1)*t1 + T23(1:i-1,1:i-1)*t2 +C + CALL DCOPY( I-2, DWORK(2), 1, T(1,PT21+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, + $ T(1,PT21+2), LDT, T(1,PT21+I), 1 ) + T(I-1, PT21+I) = ZERO + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, T(1,PT21+I), 1 ) +C +C T31(1:i-1,i) := T31(1:i-1,1:i-1)*t1 + T33(1:i-1,1:i-1)*t2 +C + CALL DCOPY( I-2, DWORK(2), 1, T(1,PT31+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, + $ T(1,PT31+2), LDT, T(1,PT31+I), 1 ) + T(I-1, PT31+I) = ZERO + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, T(1,PT31+I), 1 ) +C +C S1(1:i-1,i) := S1(1:i-1,1:i-1)*t1 + S3(1:i-1,1:i-1)*t2 +C + CALL DCOPY( I-2, DWORK(2), 1, RS(1,PS1+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-2, + $ RS(1,PS1+2), LDRS, RS(1,PS1+I), 1 ) + RS(I-1, PS1+I) = ZERO + CALL DCOPY( I-1, DWORK(K+1), 1, RS(1,PS3+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) + CALL DAXPY( I-1, ONE, RS(1,PS3+I), 1, RS(1,PS1+I), 1 ) + END IF + END IF +C +C Treat Givens rotation. +C + CM1 = CS(2*I-1) - ONE + IF ( LCOLW ) THEN + CALL DCOPY( I, W(I,1), LDW, DWORK, 1 ) + ELSE + CALL DCOPY( I, W(1,I), 1, DWORK, 1 ) + END IF + IF ( LCOLV ) THEN + CALL DCOPY( I-1, V(I,1), LDV, DWORK(K+1), 1 ) + ELSE + CALL DCOPY( I-1, V(1,I), 1, DWORK(K+1), 1 ) + END IF +C +C R1(1:i,i) = T11(1:i,1:i) * dwork(1:i) +C + [ T13(1:i-1,1:i-1) * dwork(k+1:k+i-1); 0 ] +C + CALL DCOPY( I, DWORK, 1, RS(1,PR1+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, + $ T(1,PT11+1), LDT, RS(1,PR1+I), 1 ) + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT13+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT13+I), 1, RS(1,PR1+I), 1 ) +C +C R2(1:i-1,i) = T21(1:i-1,2:i) * W(i,2:i) +C + T23(1:i-1,1:i-1) * V(i,1:i-1) +C + CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR2+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT21+2), LDT, RS(1,PR2+I), 1 ) + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT23+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT23+I), 1, RS(1,PR2+I), 1 ) +C +C R3(1:i-1,i) = T31(1:i-1,2:i) * dwork(2:i) +C + T33(1:i-1,1:i-1) * dwork(k+1:k+i-1) +C + CALL DCOPY( I-1, DWORK(2), 1, RS(1,PR3+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT31+2), LDT, RS(1,PR3+I), 1 ) + CALL DCOPY( I-1, DWORK(K+1), 1, T(1,PT33+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) + CALL DAXPY( I-1, ONE, T(1,PT33+I), 1, RS(1,PR3+I), 1 ) +C +C S2(1:i-1,i) = S1(1:i-1,2:i) * dwork(2:i) +C + S3(1:i-1,1:i-1) * dwork(k+1:k+i-1) +C + CALL DCOPY( I-1, DWORK(2), 1, RS(1,PS2+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS1+2), LDRS, RS(1,PS2+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS3+1), LDRS, DWORK(K+1), 1 ) + CALL DAXPY( I-1, ONE, DWORK(K+1), 1, RS(1,PS2+I), 1 ) + RS(I,PS2+I) = -CS(2*I) +C +C T12(1:i,i) = [ R1(1:i-1,1:i-1)*S2(1:i-1,i); 0 ] +C + (c-1) * R1(1:i,i) +C + CALL DCOPY( I-1, RS(1,PS2+I), 1, T(1,PT12+I), 1 ) + CALL DSCAL( I-1, CM1, RS(1,PS2+I), 1) + CALL DSCAL( I-1, CS(2*I), T(1,PT12+I), 1 ) + CALL DCOPY( I-1, T(1,PT12+I), 1, T(1,PT22+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PR1+1), LDRS, T(1,PT12+I), 1 ) + T(I,PT12+I) = ZERO + CALL DAXPY( I, CM1, RS(1,PR1+I), 1, T(1,PT12+I), 1 ) +C +C T22(1:i-1,i) = R2(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R2(1:i-1,i) +C + IF (I.GT.1) + $ CALL DCOPY( I-2, T(2,PT22+I), 1, T(1,PT32+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Unit diagonal', I-1, + $ RS(1,PR2+1), LDRS, T(1,PT22+I), 1 ) + CALL DAXPY( I-1, CM1, RS(1,PR2+I), 1, T(1,PT22+I), 1 ) + T(I,PT22+I) = CM1 +C +C T32(1:i-1,i) = R3(1:i-1,1:i-1)*S2(1:i-1,i) + (c-1)*R3(1:i-1,i) +C + IF ( I.GT.1 ) THEN + CALL DTRMV( 'Upper', 'No transpose', 'Non-Unit', I-2, + $ RS(1,PR3+2), LDRS, T(1,PT32+I), 1 ) + T(I-1,PT32+I) = ZERO + CALL DAXPY( I-1, CM1, RS(1,PR3+I), 1, T(1,PT32+I), 1 ) + END IF +C + IF ( TAUI.EQ.ZERO ) THEN + DO 50 J = 1, I + T(J,PT13+I) = ZERO + 50 CONTINUE + DO 60 J = 1, I + T(J,PT23+I) = ZERO + 60 CONTINUE + DO 70 J = 1, I + T(J,PT33+I) = ZERO + 70 CONTINUE + DO 80 J = 1, I + RS(J,PS3+I) = ZERO + 80 CONTINUE + ELSE +C +C Treat second Householder reflection. +C + IF ( LCOLV.AND.LCOLW ) THEN +C +C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), + $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) +C +C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), + $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) + ELSE IF ( LCOLV ) THEN +C +C Compute t1 = -tau(i) * W(1:i,i:n) * V(i:n,i). +C + CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), + $ LDW, V(I,I), 1, ZERO, DWORK, 1 ) +C +C Compute t2 = -tau(i) * V(i:n,1:i-1)' * V(i:n,i). +C + CALL DGEMV( 'Transpose', N-I+1, I-1, -TAUI, V(I,1), + $ LDV, V(I,I), 1, ZERO, DWORK(K2+1), 1 ) + ELSE IF ( LCOLW ) THEN +C +C Compute t1 = -tau(i) * W(i:n,1:i)' * V(i,i:n)'. +C + CALL DGEMV( 'Transpose', N-I+1, I, -TAUI, W(I,1), + $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) +C +C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), + $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) + ELSE +C +C Compute t1 = -tau(i) * W(1:i,i:n) * V(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I, N-I+1, -TAUI, W(1,I), + $ LDW, V(I,I), LDV, ZERO, DWORK, 1 ) +C +C Compute t2 = -tau(i) * V(1:i-1,i:n) * V(i,i:n)'. +C + CALL DGEMV( 'No Transpose', I-1, N-I+1, -TAUI, V(1,I), + $ LDV, V(I,I), LDV, ZERO, DWORK(K2+1), 1 ) + END IF +C +C T13(1:i,i) := T11(1:i,1:i)*t1 - tau(i)*T12(1:i,i) +C + [T13(1:i-1,1:i-1)*t2;0] +C + CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT13+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT13+1), LDT, T(1,PT13+I), 1 ) + T(I,PT13+I) = ZERO + CALL DCOPY( I, DWORK, 1, DWORK(K+1), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I, + $ T(1,PT11+1), LDT, DWORK(K+1), 1 ) + CALL DAXPY( I, ONE, DWORK(K+1), 1, T(1,PT13+I), 1 ) + CALL DAXPY( I, -TAUI, T(1,PT12+I), 1, T(1,PT13+I), 1 ) +C +C T23(1:i,i) := T21(1:i,1:i)*t1 - tau(i)*T22(1:i,i) +C + [T23(1:i-1,1:i-1)*t2;0] +C + CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT23+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT23+1), LDT, T(1,PT23+I), 1 ) + T(I,PT23+I) = ZERO + CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT21+2), LDT, DWORK(K+1), 1 ) + CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT23+I), 1 ) + CALL DAXPY( I, -TAUI, T(1,PT22+I), 1, T(1,PT23+I), 1 ) +C +C T33(1:i,i) := T31(1:i,1:i)*t1 - tau(i)*T32(1:i,i) +C + [T33(1:i-1,1:i-1)*t2;0] +C + CALL DCOPY( I-1, DWORK(K2+1), 1, T(1,PT33+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT33+1), LDT, T(1,PT33+I), 1 ) + CALL DCOPY( I-1, DWORK(2), 1, DWORK(K+1), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ T(1,PT31+2), LDT, DWORK(K+1), 1 ) + CALL DAXPY( I-1, ONE, DWORK(K+1), 1, T(1,PT33+I), 1 ) + CALL DAXPY( I-1, -TAUI, T(1,PT32+I), 1, T(1,PT33+I), 1 ) + T(I,PT33+I) = -TAUI +C +C S3(1:i,i) := S1(1:i,1:i)*t1 - tau(i)*S2(1:i,i) +C + [S3(1:i-1,1:i-1)*t2;0] +C + CALL DCOPY( I-1, DWORK(K2+1), 1, RS(1,PS3+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS3+1), LDRS, RS(1,PS3+I), 1 ) + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, + $ RS(1,PS1+2), LDRS, DWORK(2), 1 ) + CALL DAXPY( I-1, ONE, DWORK(2), 1, RS(1,PS3+I), 1 ) + RS(I,PS3+I) = ZERO + CALL DAXPY( I, -TAUI, RS(1,PS2+I), 1, RS(1,PS3+I), 1 ) + END IF + W(I,I) = WII + V(I,I) = VII + 90 CONTINUE +C + RETURN +C *** Last line of MB04QF *** + END diff --git a/mex/sources/libslicot/MB04QU.f b/mex/sources/libslicot/MB04QU.f new file mode 100644 index 000000000..6ae814da0 --- /dev/null +++ b/mex/sources/libslicot/MB04QU.f @@ -0,0 +1,472 @@ + SUBROUTINE MB04QU( TRANC, TRAND, TRANQ, STOREV, STOREW, M, N, K, + $ V, LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To overwrite general real m-by-n matrices C and D, or their +C transposes, with +C +C [ op(C) ] +C Q * [ ] if TRANQ = 'N', or +C [ op(D) ] +C +C T [ op(C) ] +C Q * [ ] if TRANQ = 'T', +C [ op(D) ] +C +C where Q is defined as the product of symplectic reflectors and +C Givens rotators, +C +C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C Unblocked version. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANC CHARACTER*1 +C Specifies the form of op( C ) as follows: +C = 'N': op( C ) = C; +C = 'T': op( C ) = C'; +C = 'C': op( C ) = C'. +C +C STOREV CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in V are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C STOREW CHARACTER*1 +C Specifies how the vectors which define the concatenated +C Householder reflectors contained in W are stored: +C = 'C': columnwise; +C = 'R': rowwise. +C +C TRAND CHARACTER*1 +C Specifies the form of op( D ) as follows: +C = 'N': op( D ) = D; +C = 'T': op( D ) = D'; +C = 'C': op( D ) = D'. +C +C TRANQ CHARACTER*1 +C = 'N': apply Q; +C = 'T': apply Q'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices op(C) and op(D). +C M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices op(C) and op(D). +C N >= 0. +C +C K (input) INTEGER +C The number of elementary reflectors whose product defines +C the matrix Q. M >= K >= 0. +C +C V (input) DOUBLE PRECISION array, dimension +C (LDV,K) if STOREV = 'C', +C (LDV,M) if STOREV = 'R' +C On entry with STOREV = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflectors F(i). +C On entry with STOREV = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflectors F(i). +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,M), if STOREV = 'C'; +C LDV >= MAX(1,K), if STOREV = 'R'. +C +C W (input) DOUBLE PRECISION array, dimension +C (LDW,K) if STOREW = 'C', +C (LDW,M) if STOREW = 'R' +C On entry with STOREW = 'C', the leading M-by-K part of +C this array must contain in its columns the vectors which +C define the elementary reflectors H(i). +C On entry with STOREW = 'R', the leading K-by-M part of +C this array must contain in its rows the vectors which +C define the elementary reflectors H(i). +C +C LDW INTEGER +C The leading dimension of the array W. +C LDW >= MAX(1,M), if STOREW = 'C'; +C LDW >= MAX(1,K), if STOREW = 'R'. +C +C C (input/output) DOUBLE PRECISION array, dimension +C (LDC,N) if TRANC = 'N', +C (LDC,M) if TRANC = 'T' or TRANC = 'C' +C On entry with TRANC = 'N', the leading M-by-N part of +C this array must contain the matrix C. +C On entry with TRANC = 'C' or TRANC = 'T', the leading +C N-by-M part of this array must contain the transpose of +C the matrix C. +C On exit with TRANC = 'N', the leading M-by-N part of +C this array contains the updated matrix C. +C On exit with TRANC = 'C' or TRANC = 'T', the leading +C N-by-M part of this array contains the transpose of the +C updated matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= MAX(1,M), if TRANC = 'N'; +C LDC >= MAX(1,N), if TRANC = 'T' or TRANC = 'C'. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,N) if TRAND = 'N', +C (LDD,M) if TRAND = 'T' or TRAND = 'C' +C On entry with TRAND = 'N', the leading M-by-N part of +C this array must contain the matrix D. +C On entry with TRAND = 'C' or TRAND = 'T', the leading +C N-by-M part of this array must contain the transpose of +C the matrix D. +C On exit with TRAND = 'N', the leading M-by-N part of +C this array contains the updated matrix D. +C On exit with TRAND = 'C' or TRAND = 'T', the leading +C N-by-M part of this array contains the transpose of the +C updated matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. +C LDD >= MAX(1,M), if TRAND = 'N'; +C LDD >= MAX(1,N), if TRAND = 'T' or TRAND = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -20, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSMSQ). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER STOREV, STOREW, TRANC, TRAND, TRANQ + INTEGER INFO, K, LDC, LDD, LDV, LDW, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), C(LDC,*), D(LDD,*), V(LDV,*), + $ W(LDW,*), TAU(*) +C .. Local Scalars .. + LOGICAL LCOLV, LCOLW, LTRC, LTRD, LTRQ + INTEGER I + DOUBLE PRECISION NU +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DROT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LCOLV = LSAME( STOREV, 'C' ) + LCOLW = LSAME( STOREW, 'C' ) + LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' ) + LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' ) + LTRQ = LSAME( TRANQ, 'T' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRC.OR.LSAME( TRANC, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( .NOT.( LTRQ .OR. LSAME( TRANQ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF ( .NOT.( LCOLV.OR. LSAME( STOREV, 'R' ) ) ) THEN + INFO = -4 + ELSE IF ( .NOT.( LCOLW.OR. LSAME( STOREW, 'R' ) ) ) THEN + INFO = -5 + ELSE IF ( M.LT.0 ) THEN + INFO = -6 + ELSE IF ( N.LT.0 ) THEN + INFO = -7 + ELSE IF ( K.LT.0 .OR. K.GT.M ) THEN + INFO = -8 + ELSE IF ( ( LCOLV.AND.LDV.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LCOLV.AND.LDV.LT.MAX( 1, K ) ) ) THEN + INFO = -10 + ELSE IF ( ( LCOLW.AND.LDW.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LCOLW.AND.LDW.LT.MAX( 1, K ) ) ) THEN + INFO = -12 + ELSE IF ( ( LTRC.AND.LDC.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRC.AND.LDC.LT.MAX( 1, M ) ) ) THEN + INFO = -14 + ELSE IF ( ( LTRD.AND.LDD.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRD.AND.LDD.LT.MAX( 1, M ) ) ) THEN + INFO = -16 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -20 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04QU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( K, M, N ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + IF ( LTRQ ) THEN + DO 10 I = 1, K +C +C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. +C + NU = W(I,I) + W(I,I) = ONE + IF ( LCOLW ) THEN + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), + $ LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), + $ LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), + $ LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), + $ LDD, DWORK ) + END IF + ELSE + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), + $ LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), + $ LDD, DWORK ) + END IF + END IF + W(I,I) = NU +C +C Apply G(i) to C(I,:) and D(I,:) from the left. +C + IF ( LTRC.AND.LTRD ) THEN + CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), CS(2*I) ) + ELSE IF ( LTRC ) THEN + CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), + $ CS(2*I) ) + ELSE IF ( LTRD ) THEN + CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), + $ CS(2*I) ) + ELSE + CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), + $ CS(2*I) ) + END IF +C +C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. +C + NU = V(I,I) + V(I,I) = ONE + IF ( LCOLV ) THEN + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), + $ C(I,1), LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), + $ D(I,1), LDD, DWORK ) + END IF + ELSE + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), + $ C(I,1), LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), + $ D(I,1), LDD, DWORK ) + END IF + END IF + V(I,I) = NU + 10 CONTINUE + ELSE + DO 20 I = K, 1, -1 +C +C Apply F(I) to C(I:M,:) and D(I:M,:) from the left. +C + NU = V(I,I) + V(I,I) = ONE + IF ( LCOLV ) THEN + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), + $ C(I,1), LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), 1, TAU(I), + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), 1, TAU(I), + $ D(I,1), LDD, DWORK ) + END IF + ELSE + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), + $ C(I,1), LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, V(I,I), LDV, TAU(I), + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, V(I,I), LDV, TAU(I), + $ D(I,1), LDD, DWORK ) + END IF + END IF + V(I,I) = NU +C +C Apply G(i) to C(I,:) and D(I,:) from the left. +C + IF ( LTRC.AND.LTRD ) THEN + CALL DROT( N, C(1,I), 1, D(1,I), 1, CS(2*I-1), -CS(2*I) ) + ELSE IF ( LTRC ) THEN + CALL DROT( N, C(1,I), 1, D(I,1), LDD, CS(2*I-1), + $ -CS(2*I) ) + ELSE IF ( LTRD ) THEN + CALL DROT( N, C(I,1), LDC, D(1,I), 1, CS(2*I-1), + $ -CS(2*I) ) + ELSE + CALL DROT( N, C(I,1), LDC, D(I,1), LDD, CS(2*I-1), + $ -CS(2*I) ) + END IF +C +C Apply H(I) to C(I:M,:) and D(I:M,:) from the left. +C + NU = W(I,I) + W(I,I) = ONE + IF ( LCOLW ) THEN + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, C(1,I), + $ LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, C(I,1), + $ LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), 1, NU, D(1,I), + $ LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), 1, NU, D(I,1), + $ LDD, DWORK ) + END IF + ELSE + IF ( LTRC ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, + $ C(1,I), LDC, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, C(I,1), + $ LDC, DWORK ) + END IF + IF ( LTRD ) THEN + CALL DLARF( 'Right', N, M-I+1, W(I,I), LDW, NU, + $ D(1,I), LDD, DWORK ) + ELSE + CALL DLARF( 'Left', M-I+1, N, W(I,I), LDW, NU, D(I,1), + $ LDD, DWORK ) + END IF + END IF + W(I,I) = NU + 20 CONTINUE + END IF +C + DWORK(1) = DBLE( MAX( 1, N ) ) +C *** Last line of MB04QU *** + END diff --git a/mex/sources/libslicot/MB04TB.f b/mex/sources/libslicot/MB04TB.f new file mode 100644 index 000000000..3d5ad6614 --- /dev/null +++ b/mex/sources/libslicot/MB04TB.f @@ -0,0 +1,677 @@ + SUBROUTINE MB04TB( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, + $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a symplectic URV (SURV) decomposition of a real +C 2N-by-2N matrix H, +C +C [ op(A) G ] [ op(R11) R12 ] +C H = [ ] = U R V' = U * [ ] * V' , +C [ Q op(B) ] [ 0 op(R22) ] +C +C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real +C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower +C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic +C matrices. Blocked version. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op( A ) as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op( B ) as follows: +C = 'N': op( B ) = B; +C = 'T': op( B ) = B'; +C = 'C': op( B ) = B'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ILO (input) INTEGER +C It is assumed that op(A) is already upper triangular, +C op(B) is lower triangular and Q is zero in rows and +C columns 1:ILO-1. ILO is normally set by a previous call +C to MB04DD; otherwise it should be set to 1. +C 1 <= ILO <= N, if N > 0; ILO=1, if N=0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the triangular matrix R11, and in the zero part +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix B. +C On exit, the leading N-by-N part of this array contains +C the Hessenberg matrix R22, and in the zero part +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix G. +C On exit, the leading N-by-N part of this array contains +C the matrix R12. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix Q. +C On exit, the leading N-by-N part of this array contains +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C CSL (output) DOUBLE PRECISION array, dimension (2N) +C On exit, the first 2N elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the left-hand side used to compute the SURV +C decomposition. +C +C CSR (output) DOUBLE PRECISION array, dimension (2N-2) +C On exit, the first 2N-2 elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the right-hand side used to compute the SURV +C decomposition. +C +C TAUL (output) DOUBLE PRECISION array, dimension (N) +C On exit, the first N elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied form the left-hand side. +C +C TAUR (output) DOUBLE PRECISION array, dimension (N-1) +C On exit, the first N-1 elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied form the right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK, (16*N + 5)*NB, where NB is the optimal +C block size determined by the function UE01MD. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices U and V are represented as products of symplectic +C reflectors and Givens rotators +C +C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) +C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) +C .... +C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), +C +C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) +C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) +C .... +C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). +C +C Each HU(i) has the form +C +C HU(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in +C Q(i+1:n,i), and tau in Q(i,i). +C +C Each FU(i) has the form +C +C FU(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in +C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The +C scalar nu is stored in TAUL(i). +C +C Each GU(i) is a Givens rotator acting on rows i and n+i, +C where the cosine is stored in CSL(2*i-1) and the sine in +C CSL(2*i). +C +C Each HV(i) has the form +C +C HV(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in +C Q(i,i+2:n), and tau in Q(i,i+1). +C +C Each FV(i) has the form +C +C FV(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in +C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. +C The scalar nu is stored in TAUR(i). +C +C Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1, +C where the cosine is stored in CSR(2*i-1) and the sine in +C CSR(2*i). +C +C NUMERICAL ASPECTS +C +C The algorithm requires 80/3*N**3 + ( 64*NB + 77 )*N**2 + +C ( -16*NB + 48 )*NB*N + O(N) floating point operations, where +C NB is the used block size, and is numerically backward stable. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. +C +C [2] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUB). +C +C KEYWORDS +C +C Elementary matrix operations, Matrix decompositions, Hamiltonian +C matrix +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), + $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) +C .. Local Scalars .. + LOGICAL LTRA, LTRB + INTEGER I, IB, IERR, NB, NBMIN, NH, NIB, NNB, NX, PDW, + $ PXA, PXB, PXG, PXQ, PYA, PYB, PYG, PYQ, WRKOPT +C .. External Functions .. + LOGICAL LSAME + INTEGER UE01MD + EXTERNAL LSAME, UE01MD +C .. External Subroutines .. + EXTERNAL DGEMM, MB03XU, MB04TS, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -18 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04TB', -INFO ) + RETURN + END IF +C +C Set elements 1:ILO-1 of CSL, CSR, TAUL and TAUR to their default +C values. +C + DO 10 I = 1, ILO - 1 + CSL(2*I-1) = ONE + CSL(2*I) = ZERO + CSR(2*I-1) = ONE + CSR(2*I) = ZERO + TAUL(I) = ZERO + TAUR(I) = ZERO + 10 CONTINUE +C +C Quick return if possible. +C + NH = N - ILO + 1 + IF ( NH.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Determine the block size. +C + NB = UE01MD( 1, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) + NBMIN = 2 + WRKOPT = N + IF ( NB.GT.1 .AND. NB.LT.NH ) THEN +C +C Determine when to cross over from blocked to unblocked code. +C + NX = MAX( NB, UE01MD( 3, 'MB04TB', TRANA // TRANB, N, ILO, -1 ) + $ ) + IF ( NX.LT.NH ) THEN +C +C Check whether workspace is large enough for blocked code. +C + WRKOPT = 16*N*NB + 5*NB + IF ( LDWORK.LT.WRKOPT ) THEN +C +C Not enough workspace available. Determine minimum value +C of NB, and reduce NB. +C + NBMIN = MAX( 2, UE01MD( 2, 'MB04TB', TRANA // TRANB, N, + $ ILO, -1 ) ) + NB = LDWORK / ( 16*N + 5 ) + END IF + END IF + END IF +C + NNB = N*NB + PYB = 1 + PYQ = PYB + 2*NNB + PYA = PYQ + 2*NNB + PYG = PYA + 2*NNB + PXQ = PYG + 2*NNB + PXA = PXQ + 2*NNB + PXG = PXA + 2*NNB + PXB = PXG + 2*NNB + PDW = PXB + 2*NNB +C + IF ( NB.LT.NBMIN .OR. NB.GE.NH ) THEN +C +C Use unblocked code. +C + I = ILO +C + ELSE IF ( LTRA .AND. LTRB ) THEN + DO 20 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to symplectic URV form and +C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which +C are needed to update the unreduced parts of the matrices. +C + CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, + $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), + $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, + $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, + $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), + $ TAUR(I), DWORK(PDW) ) +C +C Update the submatrix A(i+1+ib:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, + $ ONE, A(I+IB+1,I+IB), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, + $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, + $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, + $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, + $ A(I+IB+1,1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N, IB, + $ ONE, B(I+IB+1,I), LDB, DWORK(PYA+NIB), N, ONE, + $ A(I+IB+1,1), LDA ) +C +C Update the submatrix Q(i+ib:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, + $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, + $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) +C +C Update the matrix G. +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, + $ G(1,I+IB+1), LDG ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, + $ G(1,I+IB+1), LDG ) +C +C Update the submatrix B(1:n,i+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, + $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, + $ ONE, B(1,I+IB), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB+1, IB, + $ ONE, DWORK(PXB+NIB), N, A(I,I+IB), LDA, ONE, + $ B(1,I+IB), LDB ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, + $ ONE, B(I+IB+1,I+IB), LDB ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, + $ ONE, B(I+IB+1,I+IB), LDB ) + 20 CONTINUE +C + ELSE IF ( LTRA ) THEN + DO 30 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to symplectic URV form and +C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which +C are needed to update the unreduced parts of the matrices. +C + CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(I,1), LDA, + $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), + $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, + $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, + $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), + $ TAUR(I), DWORK(PDW) ) +C +C Update the submatrix A(i+1+ib:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, DWORK(PXA+NB+1), N, Q(I+IB,I), LDQ, + $ ONE, A(I+IB+1,I+IB), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB, + $ N-I-IB+1, IB, ONE, DWORK(PXA+NIB+NB+1), N, + $ A(I,I+IB), LDA, ONE, A(I+IB+1,I+IB), LDA ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, + $ ONE, Q(I,I+IB+1), LDQ, DWORK(PYA), N, ONE, + $ A(I+IB+1,1), LDA ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N, IB, + $ ONE, B(I,I+IB+1), LDB, DWORK(PYA+NIB), N, ONE, + $ A(I+IB+1,1), LDA ) +C +C Update the submatrix Q(i+ib:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I,I+IB), LDA, DWORK(PXQ+NIB+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, + $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, + $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) +C +C Update the matrix G. +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I,I+IB), LDA, DWORK(PXG+NIB), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, + $ G(1,I+IB+1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, + $ G(1,I+IB+1), LDG ) +C +C Update the submatrix B(i+ib:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, + $ ONE, B(I+IB,1), LDB ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I,I+IB), LDA, DWORK(PXB+NIB), N, ONE, + $ B(I+IB,1), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), + $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, + $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) + 30 CONTINUE +C + ELSE IF ( LTRB ) THEN + DO 40 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to symplectic URV form and +C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which +C are needed to update the unreduced parts of the matrices. +C + CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, + $ B(1,I), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), + $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, + $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, + $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), + $ TAUR(I), DWORK(PDW) ) +C +C Update the submatrix A(1:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, + $ ONE, A(I+IB,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, + $ ONE, A(I+IB,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, + $ A(1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA+NIB), N, B(I+IB+1,I), LDB, ONE, + $ A(1,I+IB+1), LDA ) +C +C Update the submatrix Q(i+ib:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, + $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No Transpose', 'Transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, + $ B(I+IB+1,I), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) +C +C Update the matrix G. +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, + $ G(1,I+IB+1), LDG ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG+NIB), N, B(I+IB+1,I), LDB, ONE, + $ G(1,I+IB+1), LDG ) +C +C Update the submatrix B(1:n,i+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, + $ IB, ONE, DWORK(PXB), N, Q(I+IB,I), LDQ, + $ ONE, B(1,I+IB), LDB ) + CALL DGEMM( 'No transpose', 'Transpose', N, N-I-IB+1, IB, + $ ONE, DWORK(PXB+NIB), N, A(I+IB,I), LDA, ONE, + $ B(1,I+IB), LDB ) + CALL DGEMM( 'Transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, Q(I,I+IB+1), LDQ, DWORK(PYB+NB), N, + $ ONE, B(I+IB+1,I+IB), LDB ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB, N-I-IB+1, + $ IB, ONE, B(I+IB+1,I), LDB, DWORK(PYB+NIB+NB), N, + $ ONE, B(I+IB+1,I+IB), LDB ) + 40 CONTINUE +C + ELSE + DO 50 I = ILO, N-NX-1, NB + IB = MIN( NB, N-I ) + NIB = N*IB +C +C Reduce rows and columns i:i+nb-1 to symplectic URV form and +C return the matrices XA, XB, XG, XQ, YA, YB, YG and YQ which +C are needed to update the unreduced parts of the matrices. +C + CALL MB03XU( LTRA, LTRB, N-I+1, I-1, IB, A(1,I), LDA, + $ B(I,1), LDB, G, LDG, Q(I,I), LDQ, DWORK(PXA), + $ N, DWORK(PXB), N, DWORK(PXG), N, DWORK(PXQ), N, + $ DWORK(PYA), N, DWORK(PYB), N, DWORK(PYG), N, + $ DWORK(PYQ), N, CSL(2*I-1), CSR(2*I-1), TAUL(I), + $ TAUR(I), DWORK(PDW) ) +C +C Update the submatrix A(1:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXA+NB+1), N, + $ ONE, A(I+IB,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I+IB,I), LDA, DWORK(PXA+NIB+NB+1), N, + $ ONE, A(I+IB,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA), N, Q(I,I+IB+1), LDQ, ONE, + $ A(1,I+IB+1), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYA+NIB), N, B(I,I+IB+1), LDB, ONE, + $ A(1,I+IB+1), LDA ) +C +C Update the submatrix Q(i+ib:n,i+1+ib:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXQ+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N-I-IB, + $ IB, ONE, A(I+IB,I), LDA, DWORK(PXQ+NIB+NB+1), N, + $ ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NB), N, + $ Q(I,I+IB+1), LDQ, ONE, Q(I+IB,I+IB+1), LDQ ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYQ+NIB+NB), N, + $ B(I,I+IB+1), LDB, ONE, Q(I+IB,I+IB+1), LDQ ) +C +C Update the matrix G. +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, Q(I+IB,I), LDQ, DWORK(PXG), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I+IB,I), LDA, DWORK(PXG+NIB), N, ONE, + $ G(I+IB,1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG), N, Q(I,I+IB+1), LDQ, ONE, + $ G(1,I+IB+1), LDG ) + CALL DGEMM( 'No transpose', 'No transpose', N, N-I-IB, IB, + $ ONE, DWORK(PYG+NIB), N, B(I,I+IB+1), LDB, ONE, + $ G(1,I+IB+1), LDG ) +C +C Update the submatrix B(i+ib:n,1:n). +C + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, + $ IB, ONE, Q(I+IB,I), LDQ, DWORK(PXB), N, + $ ONE, B(I+IB,1), LDB ) + CALL DGEMM( 'No transpose', 'Transpose', N-I-IB+1, N, IB, + $ ONE, A(I+IB,I), LDA, DWORK(PXB+NIB), N, ONE, + $ B(I+IB,1), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYB+NB), N, Q(I,I+IB+1), + $ LDQ, ONE, B(I+IB,I+IB+1), LDB ) + CALL DGEMM( 'No transpose', 'No transpose', N-I-IB+1, + $ N-I-IB, IB, ONE, DWORK(PYB+NIB+NB), N, + $ B(I,I+IB+1), LDB, ONE, B(I+IB,I+IB+1), LDB ) + 50 CONTINUE + END IF +C +C Unblocked code to reduce the rest of the matrices. +C + CALL MB04TS( TRANA, TRANB, N, I, A, LDA, B, LDB, G, LDG, Q, LDQ, + $ CSL, CSR, TAUL, TAUR, DWORK, LDWORK, IERR ) +C + DWORK(1) = DBLE( WRKOPT ) +C + RETURN +C *** Last line of MB04TB *** + END diff --git a/mex/sources/libslicot/MB04TS.f b/mex/sources/libslicot/MB04TS.f new file mode 100644 index 000000000..66f085f5f --- /dev/null +++ b/mex/sources/libslicot/MB04TS.f @@ -0,0 +1,519 @@ + SUBROUTINE MB04TS( TRANA, TRANB, N, ILO, A, LDA, B, LDB, G, LDG, + $ Q, LDQ, CSL, CSR, TAUL, TAUR, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a symplectic URV (SURV) decomposition of a real +C 2N-by-2N matrix H: +C +C [ op(A) G ] T [ op(R11) R12 ] T +C H = [ ] = U R V = U * [ ] * V , +C [ Q op(B) ] [ 0 op(R22) ] +C +C where A, B, G, Q, R12 are real N-by-N matrices, op(R11) is a real +C N-by-N upper triangular matrix, op(R22) is a real N-by-N lower +C Hessenberg matrix and U, V are 2N-by-2N orthogonal symplectic +C matrices. Unblocked version. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op( A ) as follows: +C = 'N': op( A ) = A; +C = 'T': op( A ) = A'; +C = 'C': op( A ) = A'. +C +C TRANB CHARACTER*1 +C Specifies the form of op( B ) as follows: +C = 'N': op( B ) = B; +C = 'T': op( B ) = B'; +C = 'C': op( B ) = B'. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C ILO (input) INTEGER +C It is assumed that op(A) is already upper triangular, +C op(B) is lower triangular and Q is zero in rows and +C columns 1:ILO-1. ILO is normally set by a previous call +C to MB04DD; otherwise it should be set to 1. +C 1 <= ILO <= N, if N > 0; ILO=1, if N=0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the triangular matrix R11, and in the zero part +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix B. +C On exit, the leading N-by-N part of this array contains +C the Hessenberg matrix R22, and in the zero part +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix G. +C On exit, the leading N-by-N part of this array contains +C the matrix R12. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix Q. +C On exit, the leading N-by-N part of this array contains +C information about the elementary reflectors used to +C compute the SURV decomposition. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDG >= MAX(1,N). +C +C CSL (output) DOUBLE PRECISION array, dimension (2N) +C On exit, the first 2N elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the left-hand side used to compute the SURV +C decomposition. +C +C CSR (output) DOUBLE PRECISION array, dimension (2N-2) +C On exit, the first 2N-2 elements of this array contain the +C cosines and sines of the symplectic Givens rotations +C applied from the right-hand side used to compute the SURV +C decomposition. +C +C TAUL (output) DOUBLE PRECISION array, dimension (N) +C On exit, the first N elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied from the left-hand side. +C +C TAUR (output) DOUBLE PRECISION array, dimension (N-1) +C On exit, the first N-1 elements of this array contain the +C scalar factors of some of the elementary reflectors +C applied from the right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -16, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrices U and V are represented as products of symplectic +C reflectors and Givens rotators +C +C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) +C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) +C .... +C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), +C +C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) +C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) +C .... +C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ). +C +C Each HU(i) has the form +C +C HU(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in +C Q(i+1:n,i), and tau in Q(i,i). +C +C Each FU(i) has the form +C +C FU(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i-1) = 0 and w(i) = 1; w(i+1:n) is stored on exit in +C A(i+1:n,i), if op(A) = 'N', and in A(i,i+1:n), otherwise. The +C scalar nu is stored in TAUL(i). +C +C Each GU(i) is a Givens rotator acting on rows i and n+i, +C where the cosine is stored in CSL(2*i-1) and the sine in +C CSL(2*i). +C +C Each HV(i) has the form +C +C HV(i) = I - tau * v * v' +C +C where tau is a real scalar, and v is a real vector with +C v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in +C Q(i,i+2:n), and tau in Q(i,i+1). +C +C Each FV(i) has the form +C +C FV(i) = I - nu * w * w' +C +C where nu is a real scalar, and w is a real vector with +C w(1:i) = 0 and w(i+1) = 1; w(i+2:n) is stored on exit in +C B(i,i+2:n), if op(B) = 'N', and in B(i+2:n,i), otherwise. +C The scalar nu is stored in TAUR(i). +C +C Each GV(i) is a Givens rotator acting on columns i+1 and n+i+1, +C where the cosine is stored in CSR(2*i-1) and the sine in +C CSR(2*i). +C +C NUMERICAL ASPECTS +C +C The algorithm requires 80/3 N**3 + 20 N**2 + O(N) floating point +C operations and is numerically backward stable. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DGESUV). +C +C KEYWORDS +C +C Elementary matrix operations, Matrix decompositions, Hamiltonian +C matrix +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER ILO, INFO, LDA, LDB, LDG, LDQ, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), CSL(*), CSR(*), DWORK(*), + $ G(LDG,*), Q(LDQ,*), TAUL(*), TAUR(*) +C .. Local Scalars .. + LOGICAL LTRA, LTRB + INTEGER I + DOUBLE PRECISION ALPHA, C, NU, S, TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DLARTG, DROT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LTRA = LSAME( TRANA, 'T' ) .OR. LSAME( TRANA, 'C' ) + LTRB = LSAME( TRANB, 'T' ) .OR. LSAME( TRANB, 'C' ) + IF ( .NOT.LTRA .AND. .NOT.LSAME( TRANA, 'N' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.LTRB .AND. .NOT.LSAME( TRANB, 'N' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDG.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF ( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDWORK.LT.MAX( 1, N ) ) THEN + DWORK(1) = DBLE( MAX( 1, N ) ) + INFO = -18 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04TS', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + DO 10 I = ILO, N + ALPHA = Q(I,I) + IF ( I.LT.N ) THEN +C +C Generate elementary reflector HU(i) to annihilate Q(i+1:n,i) +C + CALL DLARFG( N-I+1, ALPHA, Q(I+1,I), 1, NU ) +C +C Apply HU(i) from the left. +C + Q(I,I) = ONE + CALL DLARF( 'Left', N-I+1, N-I, Q(I,I), 1, NU, Q(I,I+1), + $ LDQ, DWORK ) + IF ( LTRA ) THEN + CALL DLARF( 'Right', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), + $ LDA, DWORK ) + ELSE + CALL DLARF( 'Left', N-I+1, N-I+1, Q(I,I), 1, NU, A(I,I), + $ LDA, DWORK ) + END IF + IF ( LTRB ) THEN + CALL DLARF( 'Right', N, N-I+1, Q(I,I), 1, NU, B(1,I), + $ LDB, DWORK ) + ELSE + CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, B(I,1), LDB, + $ DWORK ) + END IF + CALL DLARF( 'Left', N-I+1, N, Q(I,I), 1, NU, G(I,1), LDG, + $ DWORK ) + Q(I,I) = NU + ELSE + Q(I,I) = ZERO + END IF +C +C Generate symplectic Givens rotator GU(i) to annihilate Q(i,i). +C + TEMP = A(I,I) + CALL DLARTG( TEMP, ALPHA, C, S, A(I,I) ) +C +C Apply G(i) from the left. +C + IF ( LTRA ) THEN + CALL DROT( N-I, A(I+1,I), 1, Q(I,I+1), LDQ, C, S ) + ELSE + CALL DROT( N-I, A(I,I+1), LDA, Q(I,I+1), LDQ, C, S ) + END IF + IF ( LTRB ) THEN + CALL DROT( N, G(I,1), LDG, B(1,I), 1, C, S ) + ELSE + CALL DROT( N, G(I,1), LDG, B(I,1), LDB, C, S ) + END IF + CSL(2*I-1) = C + CSL(2*I) = S +C + IF ( I.LT.N ) THEN + IF ( LTRA ) THEN +C +C Generate elementary reflector FU(i) to annihilate +C A(i,i+1:n). +C + CALL DLARFG( N-I+1, A(I,I), A(I,I+1), LDA, TAUL(I) ) +C +C Apply FU(i) from the left. +C + TEMP = A(I,I) + A(I,I) = ONE + CALL DLARF( 'Right', N-I, N-I+1, A(I,I), LDA, TAUL(I), + $ A(I+1,I), LDA, DWORK ) + CALL DLARF( 'Left', N-I+1, N-I, A(I,I), LDA, TAUL(I), + $ Q(I,I+1), LDQ, DWORK ) + IF ( LTRB ) THEN + CALL DLARF( 'Right', N, N-I+1, A(I,I), LDA, TAUL(I), + $ B(1,I), LDB, DWORK ) + ELSE + CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), + $ B(I,1), LDB, DWORK ) + END IF + CALL DLARF( 'Left', N-I+1, N, A(I,I), LDA, TAUL(I), + $ G(I,1), LDG, DWORK ) + A(I,I) = TEMP + ELSE +C +C Generate elementary reflector FU(i) to annihilate +C A(i+1:n,i). +C + CALL DLARFG( N-I+1, A(I,I), A(I+1,I), 1, TAUL(I) ) +C +C Apply FU(i) from the left. +C + TEMP = A(I,I) + A(I,I) = ONE + CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), + $ A(I,I+1), LDA, DWORK ) + CALL DLARF( 'Left', N-I+1, N-I, A(I,I), 1, TAUL(I), + $ Q(I,I+1), LDQ, DWORK ) + IF ( LTRB ) THEN + CALL DLARF( 'Right', N, N-I+1, A(I,I), 1, TAUL(I), + $ B(1,I), LDB, DWORK ) + ELSE + CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), + $ B(I,1), LDB, DWORK ) + END IF + CALL DLARF( 'Left', N-I+1, N, A(I,I), 1, TAUL(I), G(I,1), + $ LDG, DWORK ) + A(I,I) = TEMP + END IF + ELSE + TAUL(I) = ZERO + END IF + IF ( I.LT.N ) + $ ALPHA = Q(I,I+1) + IF ( I.LT.N-1 ) THEN +C +C Generate elementary reflector HV(i) to annihilate Q(i,i+2:n) +C + CALL DLARFG( N-I, ALPHA, Q(I,I+2), LDQ, NU ) +C +C Apply HV(i) from the right. +C + Q(I,I+1) = ONE + CALL DLARF( 'Right', N-I, N-I, Q(I,I+1), LDQ, NU, + $ Q(I+1,I+1), LDQ, DWORK ) + IF ( LTRA ) THEN + CALL DLARF( 'Left', N-I, N, Q(I,I+1), LDQ, NU, + $ A(I+1,1), LDA, DWORK ) + ELSE + CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, + $ A(1,I+1), LDA, DWORK ) + END IF + IF ( LTRB ) THEN + CALL DLARF( 'Left', N-I, N-I+1, Q(I,I+1), LDQ, NU, + $ B(I+1,I), LDB, DWORK ) + ELSE + CALL DLARF( 'Right', N-I+1, N-I, Q(I,I+1), LDQ, NU, + $ B(I,I+1), LDB, DWORK ) + END IF + CALL DLARF( 'Right', N, N-I, Q(I,I+1), LDQ, NU, + $ G(1,I+1), LDG, DWORK ) + Q(I,I+1) = NU + ELSE IF ( I.LT.N ) THEN + Q(I,I+1) = ZERO + END IF + IF ( I.LT.N ) THEN +C +C Generate symplectic Givens rotator GV(i) to annihilate +C Q(i,i+1). +C + IF ( LTRB ) THEN + TEMP = B(I+1,I) + CALL DLARTG( TEMP, ALPHA, C, S, B(I+1,I) ) + S = -S + CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), LDB, C, S ) + ELSE + TEMP = B(I,I+1) + CALL DLARTG( TEMP, ALPHA, C, S, B(I,I+1) ) + S = -S + CALL DROT( N-I, Q(I+1,I+1), 1, B(I+1,I+1), 1, C, S ) + END IF + IF ( LTRA ) THEN + CALL DROT( N, A(I+1,1), LDA, G(1,I+1), 1, C, S ) + ELSE + CALL DROT( N, A(1,I+1), 1, G(1,I+1), 1, C, S ) + END IF + CSR(2*I-1) = C + CSR(2*I) = S + END IF + IF ( I.LT.N-1 ) THEN + IF ( LTRB ) THEN +C +C Generate elementary reflector FV(i) to annihilate +C B(i+2:n,i). +C + CALL DLARFG( N-I, B(I+1,I), B(I+2,I), 1, TAUR(I) ) +C +C Apply FV(i) from the right. +C + TEMP = B(I+1,I) + B(I+1,I) = ONE + CALL DLARF( 'Left', N-I, N-I, B(I+1,I), 1, TAUR(I), + $ B(I+1,I+1), LDB, DWORK ) + CALL DLARF( 'Right', N-I, N-I, B(I+1,I), 1, TAUR(I), + $ Q(I+1,I+1), LDQ, DWORK ) + IF ( LTRA ) THEN + CALL DLARF( 'Left', N-I, N, B(I+1,I), 1, + $ TAUR(I), A(I+1,1), LDA, DWORK ) + ELSE + CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, + $ TAUR(I), A(1,I+1), LDA, DWORK ) + END IF + CALL DLARF( 'Right', N, N-I, B(I+1,I), 1, TAUR(I), + $ G(1,I+1), LDG, DWORK ) + B(I+1,I) = TEMP + ELSE +C +C Generate elementary reflector FV(i) to annihilate +C B(i,i+2:n). +C + CALL DLARFG( N-I, B(I,I+1), B(I,I+2), LDB, TAUR(I) ) +C +C Apply FV(i) from the right. +C + TEMP = B(I,I+1) + B(I,I+1) = ONE + CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), + $ B(I+1,I+1), LDB, DWORK ) + CALL DLARF( 'Right', N-I, N-I, B(I,I+1), LDB, TAUR(I), + $ Q(I+1,I+1), LDQ, DWORK ) + IF ( LTRA ) THEN + CALL DLARF( 'Left', N-I, N, B(I,I+1), LDB, TAUR(I), + $ A(I+1,1), LDA, DWORK ) + ELSE + CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, + $ TAUR(I), A(1,I+1), LDA, DWORK ) + END IF + CALL DLARF( 'Right', N, N-I, B(I,I+1), LDB, TAUR(I), + $ G(1,I+1), LDG, DWORK ) + B(I,I+1) = TEMP + END IF + ELSE IF ( I.LT.N ) THEN + TAUR(I) = ZERO + END IF + 10 CONTINUE + DWORK(1) = DBLE( MAX( 1, N ) ) + RETURN +C *** Last line of MB04TS *** + END diff --git a/mex/sources/libslicot/MB04TT.f b/mex/sources/libslicot/MB04TT.f new file mode 100644 index 000000000..7d8e207f9 --- /dev/null +++ b/mex/sources/libslicot/MB04TT.f @@ -0,0 +1,413 @@ + SUBROUTINE MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, + $ LDA, E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANK, TOL, + $ IWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C Let A and E be M-by-N matrices with E in column echelon form. +C Let AA and EE be the following submatrices of A and E: +C AA := A(IFIRA : M ; IFICA : N) +C EE := E(IFIRA : M ; IFICA : N). +C Let Aj and Ej be the following submatrices of AA and EE: +C Aj := A(IFIRA : M ; IFICA : IFICA + NCA - 1) and +C Ej := E(IFIRA : M ; IFICA + NCA : N). +C +C To transform (AA,EE) such that Aj is row compressed while keeping +C matrix Ej in column echelon form (which may be different from the +C form on entry). +C In fact the routine performs the j-th step of Algorithm 3.2.1 in +C [1]. Furthermore, it determines the rank RANK of the submatrix Ej, +C which is equal to the number of corner points in submatrix Ej. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C M is the number of rows of the matrices A, E and Q. +C M >= 0. +C +C N (input) INTEGER +C N is the number of columns of the matrices A, E and Z. +C N >= 0. +C +C IFIRA (input) INTEGER +C IFIRA is the first row index of the submatrices Aj and Ej +C in the matrices A and E, respectively. +C +C IFICA (input) INTEGER +C IFICA and IFICA + NCA are the first column indices of the +C submatrices Aj and Ej in the matrices A and E, +C respectively. +C +C NCA (input) INTEGER +C NCA is the number of columns of the submatrix Aj in A. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, A(IFIRA : M ; IFICA : IFICA + NCA - 1) contains +C the matrix Aj. +C On exit, it contains the matrix A with AA that has been +C row compressed while keeping EE in column echelon form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, E(IFIRA : M ; IFICA + NCA : N) contains the +C matrix Ej which is in column echelon form. +C On exit, it contains the transformed matrix EE which is +C kept in column echelon form. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C ISTAIR (input/output) INTEGER array, dimension (M) +C On entry, ISTAIR contains information on the column +C echelon form of the input matrix E as follows: +C ISTAIR(i) = +j: the boundary element E(i,j) is a corner +C point; +C -j: the boundary element E(i,j) is not a +C corner point (where i=1,...,M). +C On exit, ISTAIR contains the same information for the +C transformed matrix E. +C +C RANK (output) INTEGER +C Numerical rank of the submatrix Aj in A (based on TOL). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance used when considering matrix elements +C to be zero. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MB04FZ by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C June 13, 1997, V. Sima. +C November 24, 1997, A. Varga: array starting point A(KK,LL) +C correctly set when calling DLASET. +C +C KEYWORDS +C +C Echelon form, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATQ, UPDATZ + INTEGER IFICA, IFIRA, LDA, LDE, LDQ, LDZ, M, N, NCA, + $ RANK + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER ISTAIR(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL LZERO + INTEGER I, IFICA1, IFIRA1, II, IP, IST1, IST2, ISTPVT, + $ ITYPE, JC1, JC2, JPVT, K, KK, L, LL, LSAV, MJ, + $ MK1, MXRANK, NJ + DOUBLE PRECISION BMX, BMXNRM, EIJPVT, SC, SS +C .. External Functions .. + INTEGER IDAMAX + EXTERNAL IDAMAX +C .. External Subroutines .. + EXTERNAL DLAPMT, DLASET, DROT, DROTG, DSWAP +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN +C .. Executable Statements .. +C + RANK = 0 + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C +C Initialisation. +C +C NJ = number of columns in submatrix Aj, +C MJ = number of rows in submatrices Aj and Ej. +C + NJ = NCA + MJ = M + 1 - IFIRA + IFIRA1 = IFIRA - 1 + IFICA1 = IFICA - 1 +C + DO 20 I = 1, NJ + IWORK(I) = I + 20 CONTINUE +C + K = 1 + LZERO = .FALSE. + RANK = MIN( NJ, MJ ) + MXRANK = RANK +C +C WHILE ( K <= MXRANK ) and ( LZERO = FALSE ) DO + 40 IF ( ( K.LE.MXRANK ) .AND. ( .NOT.LZERO ) ) THEN +C +C Determine column in Aj with largest max-norm. +C + BMXNRM = ZERO + LSAV = K + KK = IFIRA1 + K +C + DO 60 L = K, NJ +C +C IDAMAX call gives the relative index in column L of Aj where +C max element is found. +C Note: the first element in column L is in row K of +C matrix Aj. +C + LL = IFICA1 + L + BMX = ABS( A(IDAMAX( MJ-K+1, A(KK,LL), 1 )+KK-1,LL) ) + IF ( BMX.GT.BMXNRM ) THEN + BMXNRM = BMX + LSAV = L + END IF + 60 CONTINUE +C + LL = IFICA1 + K + IF ( BMXNRM.LT.TOL ) THEN +C +C Set submatrix of Aj to zero. +C + CALL DLASET( 'Full', MJ-K+1, NJ-K+1, ZERO, ZERO, A(KK,LL), + $ LDA ) + LZERO = .TRUE. + RANK = K - 1 + ELSE +C +C Check whether columns have to be interchanged. +C + IF ( LSAV.NE.K ) THEN +C +C Interchange the columns in A which correspond to the +C columns lsav and k in Aj. Store the permutation in IWORK. +C + CALL DSWAP( M, A(1,LL), 1, A(1,IFICA1+LSAV), 1 ) + IP = IWORK(LSAV) + IWORK(LSAV) = IWORK(K) + IWORK(K) = IP + END IF +C + K = K + 1 + MK1 = N - LL + 1 +C + DO 80 I = MJ, K, -1 +C +C II = absolute row number in A corresponding to row i in +C Aj. +C + II = IFIRA1 + I +C +C Construct Givens transformation to annihilate Aj(i,k). +C Apply the row transformation to whole matrix A +C (NOT only to Aj). +C Update row transformation matrix Q, if needed. +C + CALL DROTG( A(II-1,LL), A(II,LL), SC, SS ) + CALL DROT( MK1-1, A(II-1,LL+1), LDA, A(II,LL+1), LDA, SC, + $ SS ) + A(II,LL) = ZERO + IF ( UPDATQ ) + $ CALL DROT( M, Q(1,II-1), 1, Q(1,II), 1, SC, SS ) +C +C Determine boundary type of matrix E at rows II-1 and II. +C + IST1 = ISTAIR(II-1) + IST2 = ISTAIR(II) + IF ( ( IST1*IST2 ).GT.0 ) THEN + IF ( IST1.GT.0 ) THEN +C +C boundary form = (* x) +C (0 *) +C + ITYPE = 1 + ELSE +C +C boundary form = (x x) +C (x x) +C + ITYPE = 3 + END IF + ELSE + IF ( IST1.LT.0 ) THEN +C +C boundary form = (x x) +C (* x) +C + ITYPE = 2 + ELSE +C +C boundary form = (* x) +C (0 x) +C + ITYPE = 4 + END IF + END IF +C +C Apply row transformation also to matrix E. +C +C JC1 = absolute number of the column in E in which stair +C element of row i-1 of Ej is present. +C JC2 = absolute number of the column in E in which stair +C element of row i of Ej is present. +C +C Note: JC1 < JC2 if ITYPE = 1. +C JC1 = JC2 if ITYPE = 2, 3 or 4. +C + JC1 = ABS( IST1 ) + JC2 = ABS( IST2 ) + JPVT = MIN( JC1, JC2 ) +C + CALL DROT( N-JPVT+1, E(II-1,JPVT), LDE, E(II,JPVT), LDE, + $ SC, SS ) + EIJPVT = E(II,JPVT) +C + IF ( ITYPE.EQ.1 ) THEN +C +C Construct column Givens transformation to annihilate +C E(ii,jpvt). +C Apply column Givens transformation to matrix E +C (NOT only to Ej). +C + CALL DROTG( E(II,JPVT+1), E(II,JPVT), SC, SS ) + CALL DROT( II-1, E(1,JPVT+1), 1, E(1,JPVT), 1, SC, + $ SS ) + E(II,JPVT) = ZERO +C +C Apply this transformation also to matrix A +C (NOT only to Aj). +C Update column transformation matrix Z, if needed. +C + CALL DROT( M, A(1,JPVT+1), 1, A(1,JPVT), 1, SC, SS ) + IF ( UPDATZ ) CALL DROT( N, Z(1,JPVT+1), 1, Z(1,JPVT), + $ 1, SC, SS ) +C + ELSE IF ( ITYPE.EQ.2 ) THEN + IF ( ABS( EIJPVT ).LT.TOL ) THEN +C +C (x x) (* x) +C Boundary form has been changed from (* x) to (0 x). +C + ISTPVT = ISTAIR(II) + ISTAIR(II-1) = ISTPVT + ISTAIR(II) = -(ISTPVT+1 ) + E(II,JPVT) = ZERO + END IF +C + ELSE IF ( ITYPE.EQ.4 ) THEN + IF ( ABS( EIJPVT ).GE.TOL ) THEN +C +C (* x) (x x) +C Boundary form has been changed from (0 x) to (* x). +C + ISTPVT = ISTAIR(II-1) + ISTAIR(II-1) = -ISTPVT + ISTAIR(II) = ISTPVT + END IF + END IF + 80 CONTINUE +C + END IF + GO TO 40 + END IF +C END WHILE 40 +C +C Permute columns of Aj to original order. +C + CALL DLAPMT( .FALSE., IFIRA1+RANK, NJ, A(1,IFICA), LDA, IWORK ) +C + RETURN +C *** Last line of MB04TT *** + END diff --git a/mex/sources/libslicot/MB04TU.f b/mex/sources/libslicot/MB04TU.f new file mode 100644 index 000000000..74e81bfe1 --- /dev/null +++ b/mex/sources/libslicot/MB04TU.f @@ -0,0 +1,96 @@ + SUBROUTINE MB04TU( N, X, INCX, Y, INCY, C, S ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the Givens transformation, defined by C (cos) and S +C (sin), and interchange the vectors involved, i.e. +C +C |X(i)| | 0 1 | | C S | |X(i)| +C | | := | | x | | x | |, i = 1,...N. +C |Y(i)| | 1 0 | |-S C | |Y(i)| +C +C REMARK. This routine is a modification of DROT from BLAS. +C This routine is called only by the SLICOT routines MB04TX +C and MB04VX. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FU by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C January 26, 1998. +C +C KEYWORDS +C +C Othogonal transformation. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INCX, INCY, N + DOUBLE PRECISION C, S +C .. Array Arguments .. + DOUBLE PRECISION X(*), Y(*) +C .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I, IX, IY +C .. Executable Statements .. +C + IF ( N.LE.0 ) RETURN + IF ( ( INCX.NE.1 ) .OR. ( INCY.NE.1 ) ) THEN +C +C Code for unequal increments or equal increments not equal to 1. +C + IX = 1 + IY = 1 + IF ( INCX.LT.0 ) IX = (-N+1)*INCX + 1 + IF ( INCY.LT.0 ) IY = (-N+1)*INCY + 1 +C + DO 20 I = 1, N + DTEMP = C*Y(IY) - S*X(IX) + Y(IY) = C*X(IX) + S*Y(IY) + X(IX) = DTEMP + IX = IX + INCX + IY = IY + INCY + 20 CONTINUE +C + ELSE +C +C Code for both increments equal to 1. +C + DO 40 I = 1, N + DTEMP = C*Y(I) - S*X(I) + Y(I) = C*X(I) + S*Y(I) + X(I) = DTEMP + 40 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB04TU *** + END diff --git a/mex/sources/libslicot/MB04TV.f b/mex/sources/libslicot/MB04TV.f new file mode 100644 index 000000000..c3fa37f2d --- /dev/null +++ b/mex/sources/libslicot/MB04TV.f @@ -0,0 +1,171 @@ + SUBROUTINE MB04TV( UPDATZ, N, NRA, NCA, IFIRA, IFICA, A, LDA, E, + $ LDE, Z, LDZ ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a submatrix A(k) of A to upper triangular form by column +C Givens rotations only. +C Here A(k) = A(IFIRA:ma,IFICA:na) where ma = IFIRA - 1 + NRA, +C na = IFICA - 1 + NCA. +C Matrix A(k) is assumed to have full row rank on entry. Hence, no +C pivoting is done during the reduction process. See Algorithm 2.3.1 +C and Remark 2.3.4 in [1]. +C The constructed column transformations are also applied to matrix +C E(k) = E(1:IFIRA-1,IFICA:na). +C Note that in E columns are transformed with the same column +C indices as in A, but with row indices different from those in A. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C N (input) INTEGER +C Number of columns of A and E. N >= 0. +C +C NRA (input) INTEGER +C Number of rows in A to be transformed. 0 <= NRA <= LDA. +C +C NCA (input) INTEGER +C Number of columns in A to be transformed. 0 <= NCA <= N. +C +C IFIRA (input) INTEGER +C Index of the first row in A to be transformed. +C +C IFICA (input) INTEGER +C Index of the first column in A to be transformed. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the elements of A(IFIRA:ma,IFICA:na) must +C contain the submatrix A(k) of full row rank to be reduced +C to upper triangular form. +C On exit, it contains the transformed matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,NRA). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the elements of E(1:IFIRA-1,IFICA:na) must +C contain the submatrix E(k). +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,IFIRA-1). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FV by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, +C staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATZ + INTEGER IFICA, IFIRA, LDA, LDE, LDZ, N, NCA, NRA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I, IFIRA1, J, JPVT + DOUBLE PRECISION SC, SS +C .. External Subroutines .. + EXTERNAL DROT, DROTG +C .. Executable Statements .. +C + IF ( N.LE.0 .OR. NRA.LE.0 .OR. NCA.LE.0 ) + $ RETURN + IFIRA1 = IFIRA - 1 + JPVT = IFICA + NCA +C + DO 40 I = IFIRA1 + NRA, IFIRA, -1 + JPVT = JPVT - 1 +C + DO 20 J = JPVT - 1, IFICA, -1 +C +C Determine the Givens transformation on columns j and jpvt +C to annihilate A(i,j). Apply the transformation to these +C columns from rows 1 up to i. +C Apply the transformation also to the E-matrix (from rows 1 +C up to ifira1). +C Update column transformation matrix Z, if needed. +C + CALL DROTG( A(I,JPVT), A(I,J), SC, SS ) + CALL DROT( I-1, A(1,JPVT), 1, A(1,J), 1, SC, SS ) + A(I,J) = ZERO + CALL DROT( IFIRA1, E(1,JPVT), 1, E(1,J), 1, SC, SS ) + IF( UPDATZ ) CALL DROT( N, Z(1,JPVT), 1, Z(1,J), 1, SC, SS ) + 20 CONTINUE +C + 40 CONTINUE +C + RETURN +C *** Last line of MB04TV *** + END diff --git a/mex/sources/libslicot/MB04TW.f b/mex/sources/libslicot/MB04TW.f new file mode 100644 index 000000000..81854d9f2 --- /dev/null +++ b/mex/sources/libslicot/MB04TW.f @@ -0,0 +1,180 @@ + SUBROUTINE MB04TW( UPDATQ, M, N, NRE, NCE, IFIRE, IFICE, IFICA, A, + $ LDA, E, LDE, Q, LDQ ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a submatrix E(k) of E to upper triangular form by row +C Givens rotations only. +C Here E(k) = E(IFIRE:me,IFICE:ne), where me = IFIRE - 1 + NRE, +C ne = IFICE - 1 + NCE. +C Matrix E(k) is assumed to have full column rank on entry. Hence, +C no pivoting is done during the reduction process. See Algorithm +C 2.3.1 and Remark 2.3.4 in [1]. +C The constructed row transformations are also applied to matrix +C A(k) = A(IFIRE:me,IFICA:N). +C Note that in A(k) rows are transformed with the same row indices +C as in E but with column indices different from those in E. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C Number of rows of A and E. M >= 0. +C +C N (input) INTEGER +C Number of columns of A and E. N >= 0. +C +C NRE (input) INTEGER +C Number of rows in E to be transformed. 0 <= NRE <= M. +C +C NCE (input) INTEGER +C Number of columns in E to be transformed. 0 <= NCE <= N. +C +C IFIRE (input) INTEGER +C Index of first row in E to be transformed. +C +C IFICE (input) INTEGER +C Index of first column in E to be transformed. +C +C IFICA (input) INTEGER +C Index of first column in A to be transformed. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, this array contains the submatrix A(k). +C On exit, it contains the transformed matrix A(k). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, this array contains the submatrix E(k) of full +C column rank to be reduced to upper triangular form. +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FW by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C June 13, 1997. V. Sima. +C December 30, 1997. A. Varga: Corrected column range to apply +C transformations on the matrix E. +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, +C staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATQ + INTEGER IFICA, IFICE, IFIRE, LDA, LDE, LDQ, M, N, NCE, + $ NRE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*) +C .. Local Scalars .. + INTEGER I, IPVT, J + DOUBLE PRECISION SC, SS +C .. External Subroutines .. + EXTERNAL DROT, DROTG +C .. Executable Statements .. +C + IF ( M.LE.0 .OR. N.LE.0 .OR. NRE.LE.0 .OR. NCE.LE.0 ) + $ RETURN +C + IPVT = IFIRE - 1 +C + DO 40 J = IFICE, IFICE + NCE - 1 + IPVT = IPVT + 1 +C + DO 20 I = IPVT + 1, IFIRE + NRE - 1 +C +C Determine the Givens transformation on rows i and ipvt +C to annihilate E(i,j). +C Apply the transformation to these rows (in whole E-matrix) +C from columns j up to n . +C Apply the transformations also to the A-matrix +C (from columns ifica up to n). +C Update the row transformation matrix Q, if needed. +C + CALL DROTG( E(IPVT,J), E(I,J), SC, SS ) + CALL DROT( N-J, E(IPVT,J+1), LDE, E(I,J+1), LDE, SC, SS ) + E(I,J) = ZERO + CALL DROT( N-IFICA+1, A(IPVT,IFICA), LDA, A(I,IFICA), LDA, + $ SC, SS ) + IF( UPDATQ ) + $ CALL DROT( M, Q(1,IPVT), 1, Q(1,I), 1, SC, SS ) + 20 CONTINUE +C + 40 CONTINUE +C + RETURN +C *** Last line of MB04TW *** + END diff --git a/mex/sources/libslicot/MB04TX.f b/mex/sources/libslicot/MB04TX.f new file mode 100644 index 000000000..ff4c37128 --- /dev/null +++ b/mex/sources/libslicot/MB04TX.f @@ -0,0 +1,394 @@ + SUBROUTINE MB04TX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, + $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in +C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. +C +C On entry, it is assumed that the M-by-N matrices A and E have +C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to +C the pencil s*E - A as described in [1], i.e. +C +C | s*E(eps,inf)-A(eps,inf) | X | +C Q'(s*E - A)Z = |-------------------------|-------------| +C | 0 | s*E(r)-A(r) | +C +C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. +C This pencil contains all Kronecker column indices and infinite +C elementary divisors of the pencil s*E - A. +C The pencil s*E(r)-A(r) contains all Kronecker row indices and +C finite elementary divisors of s*E - A. +C Furthermore, the submatrices having full row and column rank in +C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be +C triangularized. +C +C On exit, the result then is +C +C Q'(s*E - A)Z = +C +C | s*E(eps)-A(eps) | X | X | +C |-----------------|-----------------|-------------| +C | 0 | s*E(inf)-A(inf) | X | +C |===================================|=============| +C | | | +C | 0 | s*E(r)-A(r) | +C +C Note that the pencil s*E(r)-A(r) is not reduced further. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C Number of rows of A and E. M >= 0. +C +C N (input) INTEGER +C Number of columns of A and E. N >= 0. +C +C NBLCKS (input/output) INTEGER +C On entry, the number of submatrices having full row rank +C (possibly zero) in A(eps,inf). +C On exit, the input value has been reduced by one, if the +C last submatrix is a 0-by-0 (empty) matrix. +C +C INUK (input/output) INTEGER array, dimension (NBLCKS) +C On entry, this array contains the row dimensions nu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full row +C rank in the pencil s*E(eps,inf)-A(eps,inf). +C On exit, this array contains the row dimensions nu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full row +C rank in the pencil s*E(eps)-A(eps). +C +C IMUK (input/output) INTEGER array, dimension (NBLCKS) +C On entry, this array contains the column dimensions mu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full +C column rank in the pencil s*E(eps,inf)-A(eps,inf). +C On exit, this array contains the column dimensions mu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full +C column rank in the pencil s*E(eps)-A(eps). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, this array contains the matrix A to be reduced. +C On exit, it contains the transformed matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, this array contains the matrix E to be reduced. +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C MNEI (output) INTEGER array, dimension (4) +C MNEI(1) = MEPS = row dimension of s*E(eps)-A(eps), +C MNEI(2) = NEPS = column dimension of s*E(eps)-A(eps), +C MNEI(3) = MINF = row dimension of s*E(inf)-A(inf), +C MNEI(4) = NINF = column dimension of s*E(inf)-A(inf). +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FX by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C June 13, 1997, V. Sima. +C November 24, 1997, A. Varga: initialization of MNEI to 0, instead +C of ZERO. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, orthogonal +C transformation, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATQ, UPDATZ + INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS +C .. Array Arguments .. + INTEGER IMUK(*), INUK(*), MNEI(4) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER CA, CE, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, + $ MINF, MUK, MUKP1, MUP, MUP1, NEPS, NINF, NUK, + $ NUP, RA, RJE, SK1P1, TK1P1, TP1 + DOUBLE PRECISION SC, SS +C .. External Subroutines .. + EXTERNAL DROTG, MB04TU +C .. Executable Statements .. +C + MNEI(1) = 0 + MNEI(2) = 0 + MNEI(3) = 0 + MNEI(4) = 0 + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C +C Initialisation. +C + ISMUK = 0 + ISNUK = 0 +C + DO 20 K = 1, NBLCKS + ISMUK = ISMUK + IMUK(K) + ISNUK = ISNUK + INUK(K) + 20 CONTINUE +C +C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). +C MEPS = Sum(k=1,...,nblcks) NU(k), +C NEPS = Sum(k=1,...,nblcks) MU(k). +C MINF, NINF are the dimensions of the pencil s*E(inf)-A(inf). +C + MEPS = ISNUK + NEPS = ISMUK + MINF = 0 + NINF = 0 +C +C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. +C + MUKP1 = 0 +C + DO 120 K = NBLCKS, 1, -1 + NUK = INUK(K) + MUK = IMUK(K) +C +C Reduce submatrix E(k,k+1) to square matrix. +C NOTE that always NU(k) >= MU(k+1) >= 0. +C +C WHILE ( NU(k) > MU(k+1) ) DO + 40 IF ( NUK.GT.MUKP1 ) THEN +C +C sk1p1 = sum(i=k+1,...,p-1) NU(i) +C tk1p1 = sum(i=k+1,...,p-1) MU(i) +C ismuk = sum(i=1,...,k) MU(i) +C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. +C + SK1P1 = 0 + TK1P1 = 0 +C + DO 100 IP = K + 1, NBLCKS +C +C Annihilate the elements originally present in the last +C row of E(k,p+1) and A(k,p). +C Start annihilating the first MU(p) - MU(p+1) elements by +C applying column Givens rotations plus interchanging +C elements. +C Use original bottom diagonal element of A(k,k) as pivot. +C Start position of pivot in A = (ra,ca). +C + TP1 = ISMUK + TK1P1 + RA = ISNUK + SK1P1 + CA = TP1 +C + MUP = IMUK(IP) + NUP = INUK(IP) + MUP1 = NUP +C + DO 60 CJA = CA, CA + MUP - NUP - 1 +C +C CJA = current column index of pivot in A. +C + CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) +C +C Apply transformations to A- and E-matrix. +C Interchange columns simultaneously. +C Update column transformation matrix Z, if needed. +C + CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, + $ SS ) + A(RA,CJA+1) = A(RA,CJA) + A(RA,CJA) = ZERO + CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) + IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), + $ 1, SC, SS ) + 60 CONTINUE +C +C Annihilate the remaining elements originally present in +C the last row of E(k,p+1) and A(k,p) by alternatingly +C applying row and column rotations plus interchanging +C elements. +C Use diagonal elements of E(p,p+1) and original bottom +C diagonal element of A(k,k) as pivots, respectively. +C (re,ce) and (ra,ca) are the starting positions of the +C pivots in E and A. +C + CE = TP1 + MUP + CA = CE - MUP1 - 1 +C + DO 80 RJE = RA + 1, RA + MUP1 +C +C (RJE,CJE) = current position pivot in E. +C + CJE = CE + 1 + CJA = CA + 1 +C +C Determine the row transformations. +C Apply these transformations to E- and A-matrix. +C Interchange the rows simultaneously. +C Update row transformation matrix Q, if needed. +C + CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) + CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), + $ LDE, SC, SS ) + E(RJE-1,CJE) = E(RJE,CJE) + E(RJE,CJE) = ZERO + CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), + $ LDA, SC, SS ) + IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, + $ Q(1,RJE-1), 1, SC, SS ) +C +C Determine the column transformations. +C Apply these transformations to A- and E-matrix. +C Interchange the columns simultaneously. +C Update column transformation matrix Z, if needed. +C + CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) + CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, + $ SS ) + A(RJE,CJA+1) = A(RJE,CJA) + A(RJE,CJA) = ZERO + CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) + IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), + $ 1, SC, SS ) + 80 CONTINUE +C + SK1P1 = SK1P1 + NUP + TK1P1 = TK1P1 + MUP +C + 100 CONTINUE +C +C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last +C row and right most column. The row and column ignored +C belong to the pencil s*E(inf)-A(inf). +C Redefine blocks in new A and E. +C + MUK = MUK - 1 + NUK = NUK - 1 + ISMUK = ISMUK - 1 + ISNUK = ISNUK - 1 + MEPS = MEPS - 1 + NEPS = NEPS - 1 + MINF = MINF + 1 + NINF = NINF + 1 +C + GO TO 40 + END IF +C END WHILE 40 +C + IMUK(K) = MUK + INUK(K) = NUK +C +C Now submatrix E(k,k+1) is square. +C +C Consider next submatrix (k:=k-1). +C + ISNUK = ISNUK - NUK + ISMUK = ISMUK - MUK + MUKP1 = MUK + 120 CONTINUE +C +C If mu(NBLCKS) = 0, then the last submatrix counted in NBLCKS is +C a 0-by-0 (empty) matrix. This "matrix" must be removed. +C + IF ( IMUK(NBLCKS).EQ.0 ) NBLCKS = NBLCKS - 1 +C +C Store dimensions of the pencils s*E(eps)-A(eps) and +C s*E(inf)-A(inf) in array MNEI. +C + MNEI(1) = MEPS + MNEI(2) = NEPS + MNEI(3) = MINF + MNEI(4) = NINF +C + RETURN +C *** Last line of MB04TX *** + END diff --git a/mex/sources/libslicot/MB04TY.f b/mex/sources/libslicot/MB04TY.f new file mode 100644 index 000000000..1a146092f --- /dev/null +++ b/mex/sources/libslicot/MB04TY.f @@ -0,0 +1,241 @@ + SUBROUTINE MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, + $ LDA, E, LDE, Q, LDQ, Z, LDZ, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the triangularization of the submatrices having full +C row and column rank in the pencil s*E(eps,inf)-A(eps,inf) below +C +C | s*E(eps,inf)-A(eps,inf) | X | +C s*E - A = |-------------------------|-------------| , +C | 0 | s*E(r)-A(r) | +C +C using Algorithm 3.3.1 in [1]. +C On entry, it is assumed that the M-by-N matrices A and E have +C been transformed to generalized Schur form by unitary +C transformations (see Algorithm 3.2.1 in [1]), and that the pencil +C s*E(eps,inf)-A(eps,inf) is in staircase form. +C This pencil contains all Kronecker column indices and infinite +C elementary divisors of the pencil s*E - A. +C The pencil s*E(r)-A(r) contains all Kronecker row indices and +C finite elementary divisors of s*E - A. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C Number of rows in A and E. M >= 0. +C +C N (input) INTEGER +C Number of columns in A and E. N >= 0. +C +C NBLCKS (input) INTEGER +C Number of submatrices having full row rank (possibly zero) +C in A(eps,inf). +C +C INUK (input) INTEGER array, dimension (NBLCKS) +C The row dimensions nu(k) (k=1, 2, ..., NBLCKS) of the +C submatrices having full row rank in the pencil +C s*E(eps,inf)-A(eps,inf). +C +C IMUK (input) INTEGER array, dimension (NBLCKS) +C The column dimensions mu(k) (k=1, 2, ..., NBLCKS) of the +C submatrices having full column rank in the pencil. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, this array contains the matrix A to be reduced. +C On exit, it contains the transformed matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, this array contains the matrix E to be reduced. +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if incorrect dimensions of a full column rank +C submatrix; +C = 2: if incorrect dimensions of a full row rank +C submatrix. +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB04FY by Th.G.J. Beelen, +C Philips Glass Eindhoven, Holland. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, +C staircase form. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + LOGICAL UPDATQ, UPDATZ + INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKS +C .. Array Arguments .. + INTEGER IMUK(*), INUK(*) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER IFICA, IFICE, IFIRE, ISMUK, ISNUK1, K, MUK, + $ MUKP1, NUK +C .. External Subroutines .. + EXTERNAL MB04TV, MB04TW +C .. Executable Statements .. +C + INFO = 0 + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C +C ISMUK = sum(i=1,...,k) MU(i), +C ISNUK1 = sum(i=1,...,k-1) NU(i). +C + ISMUK = 0 + ISNUK1 = 0 +C + DO 20 K = 1, NBLCKS + ISMUK = ISMUK + IMUK(K) + ISNUK1 = ISNUK1 + INUK(K) + 20 CONTINUE +C +C Note: ISNUK1 has not yet the correct value. +C + MUKP1 = 0 +C + DO 40 K = NBLCKS, 1, -1 + MUK = IMUK(K) + NUK = INUK(K) + ISNUK1 = ISNUK1 - NUK +C +C Determine left upper absolute co-ordinates of E(k) in E-matrix +C and of A(k) in A-matrix. +C + IFIRE = 1 + ISNUK1 + IFICE = 1 + ISMUK + IFICA = IFICE - MUK +C +C Reduce E(k) to upper triangular form using Givens +C transformations on rows only. Apply the same transformations +C to the rows of A(k). +C + IF ( MUKP1.GT.NUK ) THEN + INFO = 1 + RETURN + END IF +C + CALL MB04TW( UPDATQ, M, N, NUK, MUKP1, IFIRE, IFICE, IFICA, A, + $ LDA, E, LDE, Q, LDQ ) +C +C Reduce A(k) to upper triangular form using Givens +C transformations on columns only. Apply the same transformations +C to the columns in the E-matrix. +C + IF ( NUK.GT.MUK ) THEN + INFO = 2 + RETURN + END IF +C + CALL MB04TV( UPDATZ, N, NUK, MUK, IFIRE, IFICA, A, LDA, E, LDE, + $ Z, LDZ ) +C + ISMUK = ISMUK - MUK + MUKP1 = MUK + 40 CONTINUE +C + RETURN +C *** Last line of MB04TY *** + END diff --git a/mex/sources/libslicot/MB04UD.f b/mex/sources/libslicot/MB04UD.f new file mode 100644 index 000000000..a5e2ba347 --- /dev/null +++ b/mex/sources/libslicot/MB04UD.f @@ -0,0 +1,375 @@ + SUBROUTINE MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, + $ Z, LDZ, RANKE, ISTAIR, TOL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute orthogonal transformations Q and Z such that the +C transformed pencil Q'(sE-A)Z has the E matrix in column echelon +C form, where E and A are M-by-N matrices. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBQ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Q the unitary row permutations, as follows: +C = 'N': Do not form Q; +C = 'I': Q is initialized to the unit matrix and the +C unitary row permutation matrix Q is returned; +C = 'U': The given matrix Q is updated by the unitary +C row permutations used in the reduction. +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the unitary column transformations, as follows: +C = 'N': Do not form Z; +C = 'I': Z is initialized to the unit matrix and the +C unitary transformation matrix Z is returned; +C = 'U': The given matrix Z is updated by the unitary +C transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in the matrices A, E and the order of +C the matrix Q. M >= 0. +C +C N (input) INTEGER +C The number of columns in the matrices A, E and the order +C of the matrix Z. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the A matrix of the pencil sE-A. +C On exit, the leading M-by-N part of this array contains +C the unitary transformed matrix Q' * A * Z. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading M-by-N part of this array must +C contain the E matrix of the pencil sE-A, to be reduced to +C column echelon form. +C On exit, the leading M-by-N part of this array contains +C the unitary transformed matrix Q' * E * Z, which is in +C column echelon form. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if JOBQ = 'U', then the leading M-by-M part of +C this array must contain a given matrix Q (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading M-by-M part of this array contains the product of +C the input matrix Q and the row permutation matrix used to +C transform the rows of matrix E. +C On exit, if JOBQ = 'I', then the leading M-by-M part of +C this array contains the matrix of accumulated unitary +C row transformations performed. +C If JOBQ = 'N', the array Q is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDQ = 1 and +C declare this array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. If JOBQ = 'U' or +C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if JOBZ = 'U', then the leading N-by-N part of +C this array must contain a given matrix Z (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading N-by-N part of this array contains the product of +C the input matrix Z and the column transformation matrix +C used to transform the columns of matrix E. +C On exit, if JOBZ = 'I', then the leading N-by-N part of +C this array contains the matrix of accumulated unitary +C column transformations performed. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'U' or +C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C RANKE (output) INTEGER +C The computed rank of the unitary transformed matrix E. +C +C ISTAIR (output) INTEGER array, dimension (M) +C This array contains information on the column echelon form +C of the unitary transformed matrix E. Specifically, +C ISTAIR(i) = +j if the first non-zero element E(i,j) +C is a corner point and -j otherwise, for i = 1,2,...,M. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance below which matrix elements are considered +C to be zero. If the user sets TOL to be less than (or +C equal to) zero then the tolerance is taken as +C EPS * MAX(ABS(E(I,J))), where EPS is the machine +C precision (see LAPACK Library routine DLAMCH), +C I = 1,2,...,M and J = 1,2,...,N. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension MAX(M,N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an M-by-N matrix pencil sE-A with E not necessarily regular, +C the routine computes a unitary transformed pencil Q'(sE-A)Z such +C that the matrix Q' * E * Z is in column echelon form (trapezoidal +C form). Further details can be found in [1]. +C +C [An M-by-N matrix E with rank(E) = r is said to be in column +C echelon form if the following conditions are satisfied: +C (a) the first (N - r) columns contain only zero elements; and +C (b) if E(i(k),k) is the last nonzero element in column k for +C k = N-r+1,...,N, i.e. E(i(k),k) <> 0 and E(j,k) = 0 for +C j > i(k), then 1 <= i(N-r+1) < i(N-r+2) < ... < i(N) <= M.] +C +C REFERENCES +C +C [1] Beelen, Th. and Van Dooren, P. +C An improved algorithm for the computation of Kronecker's +C canonical form of a singular pencil. +C Linear Algebra and Applications, 105, pp. 9-65, 1988. +C +C NUMERICAL ASPECTS +C +C It is shown in [1] that the algorithm is numerically backward +C stable. The operations count is proportional to (MAX(M,N))**3. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Based on Release 3.0 routine MB04SD modified by A. Varga, +C German Aerospace Research Establishment, Oberpfaffenhofen, +C Germany, Dec. 1997, to transform also the matrix A. +C +C REVISIONS +C +C A. Varga, DLR Oberpfaffenhofen, June 2005. +C +C KEYWORDS +C +C Echelon form, orthogonal transformation, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBQ, JOBZ + INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, RANKE + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER ISTAIR(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL LJOBQI, LJOBZI, LZERO, UPDATQ, UPDATZ + INTEGER I, K, KM1, L, LK, MNK, NR1 + DOUBLE PRECISION EMX, EMXNRM, TAU, TOLER +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DLASET, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LJOBQI = LSAME( JOBQ, 'I' ) + UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) + LJOBZI = LSAME( JOBZ, 'I' ) + UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDE.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. + $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. + $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04UD', -INFO ) + RETURN + END IF +C +C Initialize Q and Z to the identity matrices, if needed. +C + IF ( LJOBQI ) + $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) + IF ( LJOBZI ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + RANKE = MIN( M, N ) +C + IF ( RANKE.EQ.0 ) + $ RETURN +C + TOLER = TOL + IF ( TOLER.LE.ZERO ) + $ TOLER = DLAMCH( 'Epsilon' )*DLANGE( 'M', M, N, E, LDE, DWORK ) +C + K = N + LZERO = .FALSE. +C +C WHILE ( ( K > 0 ) AND ( NOT a zero submatrix encountered ) ) DO + 20 IF ( ( K.GT.0 ) .AND. ( .NOT. LZERO ) ) THEN +C +C Intermediate form of E +C +C <--k--><--n-k-> +C l=1 |x....x| | +C | | | +C | Ek | X | +C | | | +C l=m-n+k |x....x| | +C ---------------- +C | |x ... x| } +C | O | x x x| } +C | | x x| } n-k +C | | x| } +C +C where submatrix Ek = E[1:m-n+k;1:k]. +C +C Determine row LK in submatrix Ek with largest max-norm +C (starting with row m-n+k). +C + MNK = M - N + K + EMXNRM = ZERO + LK = MNK +C + DO 40 L = MNK, 1, -1 + EMX = ABS( E(L,IDAMAX( K, E(L,1), LDE )) ) + IF ( EMX.GT.EMXNRM ) THEN + EMXNRM = EMX + LK = L + END IF + 40 CONTINUE +C + IF ( EMXNRM.LE.TOLER ) THEN +C +C Set submatrix Ek to zero. +C + CALL DLASET( 'Full', MNK, K, ZERO, ZERO, E, LDE ) + LZERO = .TRUE. + RANKE = N - K + ELSE +C +C Submatrix Ek is not considered to be identically zero. +C Check whether rows have to be interchanged. +C + IF ( LK.NE.MNK ) THEN +C +C Interchange rows lk and m-n+k in whole A- and E-matrix +C and update the row transformation matrix Q, if needed. +C (For Q, the number of elements involved is m.) +C + CALL DSWAP( N, E(LK,1), LDE, E(MNK,1), LDE ) + CALL DSWAP( N, A(LK,1), LDA, A(MNK,1), LDA ) + IF( UPDATQ ) CALL DSWAP( M, Q(1,LK), 1, Q(1,MNK), 1 ) + END IF +C + KM1 = K - 1 +C +C Determine a Householder transformation to annihilate +C E(m-n+k,1:k-1) using E(m-n+k,k) as pivot. +C Apply the transformation to the columns of A and Ek +C (number of elements involved is m for A and m-n+k for Ek). +C Update the column transformation matrix Z, if needed +C (number of elements involved is n). +C + CALL DLARFG( K, E(MNK,K), E(MNK,1), LDE, TAU ) + EMX = E(MNK,K) + E(MNK,K) = ONE + CALL DLARF( 'Right', MNK-1, K, E(MNK,1), LDE, TAU, E, LDE, + $ DWORK ) + CALL DLARF( 'Right', M, K, E(MNK,1), LDE, TAU, A, LDA, + $ DWORK ) + IF( UPDATZ ) CALL DLARF( 'Right', N, K, E(MNK,1), LDE, TAU, + $ Z, LDZ, DWORK ) + E(MNK,K) = EMX + CALL DLASET( 'Full', 1, KM1, ZERO, ZERO, E(MNK,1), LDE ) +C + K = KM1 + END IF + GO TO 20 + END IF +C END WHILE 20 +C +C Initialise administration staircase form, i.e. +C ISTAIR(i) = j if E(i,j) is a nonzero corner point +C = -j if E(i,j) is on the boundary but is no corner +C point. +C Thus, +C ISTAIR(m-k) = n-k for k=0,...,rank(E)-1 +C = -(n-rank(E)+1) for k=rank(E),...,m-1. +C + DO 60 I = 0, RANKE - 1 + ISTAIR(M-I) = N - I + 60 CONTINUE +C + NR1 = -(N - RANKE + 1) +C + DO 80 I = 1, M - RANKE + ISTAIR(I) = NR1 + 80 CONTINUE +C + RETURN +C *** Last line of MB04UD *** + END diff --git a/mex/sources/libslicot/MB04VD.f b/mex/sources/libslicot/MB04VD.f new file mode 100644 index 000000000..e83817aad --- /dev/null +++ b/mex/sources/libslicot/MB04VD.f @@ -0,0 +1,540 @@ + SUBROUTINE MB04VD( MODE, JOBQ, JOBZ, M, N, RANKE, A, LDA, E, LDE, + $ Q, LDQ, Z, LDZ, ISTAIR, NBLCKS, NBLCKI, IMUK, + $ INUK, IMUK0, MNEI, TOL, IWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute orthogonal transformations Q and Z such that the +C transformed pencil Q'(sE-A)Z is in upper block triangular form, +C where E is an M-by-N matrix in column echelon form (see SLICOT +C Library routine MB04UD) and A is an M-by-N matrix. +C +C If MODE = 'B', then the matrices A and E are transformed into the +C following generalized Schur form by unitary transformations Q1 +C and Z1 : +C +C | sE(eps,inf)-A(eps,inf) | X | +C Q1'(sE-A)Z1 = |------------------------|------------|. (1) +C | O | sE(r)-A(r) | +C +C The pencil sE(eps,inf)-A(eps,inf) is in staircase form, and it +C contains all Kronecker column indices and infinite elementary +C divisors of the pencil sE-A. The pencil sE(r)-A(r) contains all +C Kronecker row indices and elementary divisors of sE-A. +C Note: X is a pencil. +C +C If MODE = 'T', then the submatrices having full row and column +C rank in the pencil sE(eps,inf)-A(eps,inf) in (1) are +C triangularized by applying unitary transformations Q2 and Z2 to +C Q1'*(sE-A)*Z1. +C +C If MODE = 'S', then the pencil sE(eps,inf)-A(eps,inf) in (1) is +C separated into sE(eps)-A(eps) and sE(inf)-A(inf) by applying +C unitary transformations Q3 and Z3 to Q2'*Q1'*(sE-A)*Z1*Z2. +C +C This gives +C +C | sE(eps)-A(eps) | X | X | +C |----------------|----------------|------------| +C | O | sE(inf)-A(inf) | X | +C Q'(sE-A)Z =|=================================|============| (2) +C | | | +C | O | sE(r)-A(r) | +C +C where Q = Q1*Q2*Q3 and Z = Z1*Z2*Z3. +C Note: the pencil sE(r)-A(r) is not reduced further. +C +C ARGUMENTS +C +C Mode Parameters +C +C MODE CHARACTER*1 +C Specifies the desired structure of the transformed +C pencil Q'(sE-A)Z to be computed as follows: +C = 'B': Basic reduction given by (1); +C = 'T': Further reduction of (1) to triangular form; +C = 'S': Further separation of sE(eps,inf)-A(eps,inf) +C in (1) into the two pencils in (2). +C +C JOBQ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = 'N': Do not form Q; +C = 'I': Q is initialized to the unit matrix and the +C orthogonal transformation matrix Q is returned; +C = 'U': The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = 'N': Do not form Z; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned; +C = 'U': The given matrix Z is updated by the orthogonal +C transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in the matrices A, E and the order of +C the matrix Q. M >= 0. +C +C N (input) INTEGER +C The number of columns in the matrices A, E and the order +C of the matrix Z. N >= 0. +C +C RANKE (input) INTEGER +C The rank of the matrix E in column echelon form. +C RANKE >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix to be row compressed. +C On exit, the leading M-by-N part of this array contains +C the matrix that has been row compressed while keeping +C matrix E in column echelon form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading M-by-N part of this array must +C contain the matrix in column echelon form to be +C transformed equivalent to matrix A. +C On exit, the leading M-by-N part of this array contains +C the matrix that has been transformed equivalent to matrix +C A. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if JOBQ = 'U', then the leading M-by-M part of +C this array must contain a given matrix Q (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading M-by-M part of this array contains the product of +C the input matrix Q and the row transformation matrix used +C to transform the rows of matrices A and E. +C On exit, if JOBQ = 'I', then the leading M-by-M part of +C this array contains the matrix of accumulated orthogonal +C row transformations performed. +C If JOBQ = 'N', the array Q is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDQ = 1 and +C declare this array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. If JOBQ = 'U' or +C JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if JOBZ = 'U', then the leading N-by-N part of +C this array must contain a given matrix Z (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading N-by-N part of this array contains the product of +C the input matrix Z and the column transformation matrix +C used to transform the columns of matrices A and E. +C On exit, if JOBZ = 'I', then the leading N-by-N part of +C this array contains the matrix of accumulated orthogonal +C column transformations performed. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'U' or +C JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C ISTAIR (input/output) INTEGER array, dimension (M) +C On entry, this array must contain information on the +C column echelon form of the unitary transformed matrix E. +C Specifically, ISTAIR(i) must be set to +j if the first +C non-zero element E(i,j) is a corner point and -j +C otherwise, for i = 1,2,...,M. +C On exit, this array contains no useful information. +C +C NBLCKS (output) INTEGER +C The number of submatrices having full row rank greater +C than or equal to 0 detected in matrix A in the pencil +C sE(x)-A(x), +C where x = eps,inf if MODE = 'B' or 'T', +C or x = eps if MODE = 'S'. +C +C NBLCKI (output) INTEGER +C If MODE = 'S', the number of diagonal submatrices in the +C pencil sE(inf)-A(inf). If MODE = 'B' or 'T' then +C NBLCKI = 0. +C +C IMUK (output) INTEGER array, dimension (MAX(N,M+1)) +C The leading NBLCKS elements of this array contain the +C column dimensions mu(1),...,mu(NBLCKS) of the submatrices +C having full column rank in the pencil sE(x)-A(x), +C where x = eps,inf if MODE = 'B' or 'T', +C or x = eps if MODE = 'S'. +C +C INUK (output) INTEGER array, dimension (MAX(N,M+1)) +C The leading NBLCKS elements of this array contain the +C row dimensions nu(1),...,nu(NBLCKS) of the submatrices +C having full row rank in the pencil sE(x)-A(x), +C where x = eps,inf if MODE = 'B' or 'T', +C or x = eps if MODE = 'S'. +C +C IMUK0 (output) INTEGER array, dimension (limuk0), +C where limuk0 = N if MODE = 'S' and 1, otherwise. +C If MODE = 'S', then the leading NBLCKI elements of this +C array contain the dimensions mu0(1),...,mu0(NBLCKI) +C of the square diagonal submatrices in the pencil +C sE(inf)-A(inf). +C Otherwise, IMUK0 is not referenced and can be supplied +C as a dummy array. +C +C MNEI (output) INTEGER array, dimension (3) +C If MODE = 'B' or 'T' then +C MNEI(1) contains the row dimension of +C sE(eps,inf)-A(eps,inf); +C MNEI(2) contains the column dimension of +C sE(eps,inf)-A(eps,inf); +C MNEI(3) = 0. +C If MODE = 'S', then +C MNEI(1) contains the row dimension of sE(eps)-A(eps); +C MNEI(2) contains the column dimension of sE(eps)-A(eps); +C MNEI(3) contains the order of the regular pencil +C sE(inf)-A(inf). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance below which matrix elements are considered +C to be zero. If the user sets TOL to be less than (or +C equal to) zero then the tolerance is taken as +C EPS * MAX( ABS(A(I,J)), ABS(E(I,J)) ), where EPS is the +C machine precision (see LAPACK Library routine DLAMCH), +C I = 1,2,...,M and J = 1,2,...,N. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C > 0: if incorrect rank decisions were revealed during the +C triangularization phase. This failure is not likely +C to occur. The possible values are: +C = 1: if incorrect dimensions of a full column rank +C submatrix; +C = 2: if incorrect dimensions of a full row rank +C submatrix. +C +C METHOD +C +C Let sE - A be an arbitrary pencil. Prior to calling the routine, +C this pencil must be transformed into a pencil with E in column +C echelon form. This may be accomplished by calling the SLICOT +C Library routine MB04UD. Depending on the value of MODE, +C submatrices of A and E are then reduced to one of the forms +C described above. Further details can be found in [1]. +C +C REFERENCES +C +C [1] Beelen, Th. and Van Dooren, P. +C An improved algorithm for the computation of Kronecker's +C canonical form of a singular pencil. +C Linear Algebra and Applications, 105, pp. 9-65, 1988. +C +C NUMERICAL ASPECTS +C +C It is shown in [1] that the algorithm is numerically backward +C stable. The operations count is proportional to (MAX(M,N))**3. +C +C FURTHER COMMENTS +C +C The difference mu(k)-nu(k), for k = 1,2,...,NBLCKS, is the number +C of elementary Kronecker blocks of size k x (k+1). +C +C If MODE = 'B' or 'T' on entry, then the difference nu(k)-mu(k+1), +C for k = 1,2,...,NBLCKS, is the number of infinite elementary +C divisors of degree k (with mu(NBLCKS+1) = 0). +C +C If MODE = 'S' on entry, then the difference mu0(k)-mu0(k+1), +C for k = 1,2,...,NBLCKI, is the number of infinite elementary +C divisors of degree k (with mu0(NBLCKI+1) = 0). +C In the pencil sE(r)-A(r), the pencils sE(f)-A(f) and +C sE(eta)-A(eta) can be separated by pertransposing the pencil +C sE(r)-A(r) and calling the routine with MODE set to 'B'. The +C result has got to be pertransposed again. (For more details see +C [1]). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Based on Release 3.0 routine MB04TD modified by A. Varga, +C German Aerospace Research Establishment, Oberpfaffenhofen, +C Germany, Nov. 1997, as follows: +C 1) NBLCKI is added; +C 2) the significance of IMUK0 and MNEI is changed; +C 3) INUK0 is removed. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, +C staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBQ, JOBZ, MODE + INTEGER INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKI, NBLCKS, + $ RANKE + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IMUK(*), IMUK0(*), INUK(*), ISTAIR(*), IWORK(*), + $ MNEI(*) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL FIRST, FIRSTI, LJOBQI, LJOBZI, LMODEB, LMODES, + $ LMODET, UPDATQ, UPDATZ + INTEGER I, IFICA, IFIRA, ISMUK, ISNUK, JK, K, NCA, NRA, + $ RANKA + DOUBLE PRECISION TOLER +C .. Local Arrays .. + DOUBLE PRECISION DWORK(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DLASET, MB04TT, MB04TY, MB04VX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. Executable Statements .. +C + INFO = 0 + LMODEB = LSAME( MODE, 'B' ) + LMODET = LSAME( MODE, 'T' ) + LMODES = LSAME( MODE, 'S' ) + LJOBQI = LSAME( JOBQ, 'I' ) + UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' ) + LJOBZI = LSAME( JOBZ, 'I' ) + UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LMODEB .AND. .NOT.LMODET .AND. .NOT.LMODES ) THEN + INFO = -1 + ELSE IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN + INFO = -2 + ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( RANKE.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR. + $ UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR. + $ UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04VD', -INFO ) + RETURN + END IF +C +C Initialize Q and Z to the identity matrices, if needed. +C + IF ( LJOBQI ) + $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ ) + IF ( LJOBZI ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + NBLCKS = 0 + NBLCKI = 0 +C + IF ( N.EQ.0 ) THEN + MNEI(1) = 0 + MNEI(2) = 0 + MNEI(3) = 0 + RETURN + END IF +C + IF ( M.EQ.0 ) THEN + NBLCKS = N + DO 10 I = 1, N + IMUK(I) = 1 + INUK(I) = 0 + 10 CONTINUE + MNEI(1) = 0 + MNEI(2) = N + MNEI(3) = 0 + RETURN + END IF +C + TOLER = TOL + IF ( TOLER.LE.ZERO ) + $ TOLER = DLAMCH( 'Epsilon' )* + $ MAX( DLANGE( 'M', M, N, A, LDA, DWORK ), + $ DLANGE( 'M', M, N, E, LDE, DWORK ) ) +C +C A(k) is the submatrix in A that will be row compressed. +C +C ISMUK = sum(i=1,..,k) MU(i), ISNUK = sum(i=1,...,k) NU(i), +C IFIRA, IFICA: first row and first column index of A(k) in A. +C NRA, NCA: number of rows and columns in A(k). +C + IFIRA = 1 + IFICA = 1 + NRA = M + NCA = N - RANKE + ISNUK = 0 + ISMUK = 0 + K = 0 +C +C Initialization of the arrays INUK and IMUK. +C + DO 20 I = 1, M + 1 + INUK(I) = -1 + 20 CONTINUE +C +C Note: it is necessary that array INUK has DIMENSION M+1 since it +C is possible that M = 1 and NBLCKS = 2. +C Example sE-A = (0 0 s -1). +C + DO 40 I = 1, N + IMUK(I) = -1 + 40 CONTINUE +C +C Compress the rows of A while keeping E in column echelon form. +C +C REPEAT +C + 60 K = K + 1 + CALL MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, LDA, + $ E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANKA, TOLER, + $ IWORK ) + IMUK(K) = NCA + ISMUK = ISMUK + NCA +C + INUK(K) = RANKA + ISNUK = ISNUK + RANKA + NBLCKS = NBLCKS + 1 +C +C If the rank of A(k) is nra then A has full row rank; +C JK = the first column index (in A) after the right most column +C of matrix A(k+1). (In case A(k+1) is empty, then JK = N+1.) +C + IFIRA = 1 + ISNUK + IFICA = 1 + ISMUK + IF ( IFIRA.GT.M ) THEN + JK = N + 1 + ELSE + JK = ABS( ISTAIR(IFIRA) ) + END IF + NRA = M - ISNUK + NCA = JK - 1 - ISMUK +C +C If NCA > 0 then there can be done some more row compression +C of matrix A while keeping matrix E in column echelon form. +C + IF ( NCA.GT.0 ) GO TO 60 +C UNTIL NCA <= 0 +C +C Matrix E(k+1) has full column rank since NCA = 0. +C Reduce A and E by ignoring all rows and columns corresponding +C to E(k+1). Ignoring these columns in E changes the ranks of the +C submatrices E(i), (i=1,...,k-1). +C + MNEI(1) = ISNUK + MNEI(2) = ISMUK + MNEI(3) = 0 +C + IF ( LMODEB ) + $ RETURN +C +C Triangularization of the submatrices in A and E. +C + CALL MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, + $ LDE, Q, LDQ, Z, LDZ, INFO ) +C + IF ( INFO.GT.0 .OR. LMODET ) + $ RETURN +C +C Save the row dimensions of the diagonal submatrices in pencil +C sE(eps,inf)-A(eps,inf). +C + DO 80 I = 1, NBLCKS + IMUK0(I) = INUK(I) + 80 CONTINUE +C +C Reduction to square submatrices E(k)'s in E. +C + CALL MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E, + $ LDE, Q, LDQ, Z, LDZ, MNEI ) +C +C Determine the dimensions of the inf diagonal submatrices and +C update block numbers if necessary. +C + FIRST = .TRUE. + FIRSTI = .TRUE. + NBLCKI = NBLCKS + K = NBLCKS +C + DO 100 I = K, 1, -1 + IMUK0(I) = IMUK0(I) - INUK(I) + IF ( FIRSTI .AND. IMUK0(I).EQ.0 ) THEN + NBLCKI = NBLCKI - 1 + ELSE + FIRSTI = .FALSE. + END IF + IF ( FIRST .AND. IMUK(I).EQ.0 ) THEN + NBLCKS = NBLCKS - 1 + ELSE + FIRST = .FALSE. + END IF + 100 CONTINUE +C + RETURN +C *** Last line of MB04VD *** + END diff --git a/mex/sources/libslicot/MB04VX.f b/mex/sources/libslicot/MB04VX.f new file mode 100644 index 000000000..92cfab1cd --- /dev/null +++ b/mex/sources/libslicot/MB04VX.f @@ -0,0 +1,384 @@ + SUBROUTINE MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, + $ LDA, E, LDE, Q, LDQ, Z, LDZ, MNEI ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To separate the pencils s*E(eps)-A(eps) and s*E(inf)-A(inf) in +C s*E(eps,inf)-A(eps,inf) using Algorithm 3.3.3 in [1]. +C +C On entry, it is assumed that the M-by-N matrices A and E have +C been obtained after applying the Algorithms 3.2.1 and 3.3.1 to +C the pencil s*E - A as described in [1], i.e. +C +C | s*E(eps,inf)-A(eps,inf) | X | +C Q'(s*E - A)Z = |-------------------------|-------------| +C | 0 | s*E(r)-A(r) | +C +C Here the pencil s*E(eps,inf)-A(eps,inf) is in staircase form. +C This pencil contains all Kronecker column indices and infinite +C elementary divisors of the pencil s*E - A. +C The pencil s*E(r)-A(r) contains all Kronecker row indices and +C finite elementary divisors of s*E - A. +C Furthermore, the submatrices having full row and column rank in +C the pencil s*E(eps,inf)-A(eps,inf) are assumed to be +C triangularized. +C +C On exit, the result then is +C +C Q'(s*E - A)Z = +C +C | s*E(eps)-A(eps) | X | X | +C |-----------------|-----------------|-------------| +C | 0 | s*E(inf)-A(inf) | X | +C |===================================|=============| +C | | | +C | 0 | s*E(r)-A(r) | +C +C Note that the pencil s*E(r)-A(r) is not reduced further. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPDATQ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Q the orthogonal row transformations, as follows: +C = .FALSE.: Do not form Q; +C = .TRUE.: The given matrix Q is updated by the orthogonal +C row transformations used in the reduction. +C +C UPDATZ LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal column transformations, as +C follows: +C = .FALSE.: Do not form Z; +C = .TRUE.: The given matrix Z is updated by the orthogonal +C column transformations used in the reduction. +C +C Input/Output Parameters +C +C M (input) INTEGER +C Number of rows of A and E. M >= 0. +C +C N (input) INTEGER +C Number of columns of A and E. N >= 0. +C +C NBLCKS (input) INTEGER +C The number of submatrices having full row rank (possibly +C zero) in A(eps,inf). +C +C INUK (input/output) INTEGER array, dimension (NBLCKS) +C On entry, this array contains the row dimensions nu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full row +C rank in the pencil s*E(eps,inf)-A(eps,inf). +C On exit, this array contains the row dimensions nu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full row +C rank in the pencil s*E(eps)-A(eps). +C +C IMUK (input/output) INTEGER array, dimension (NBLCKS) +C On entry, this array contains the column dimensions mu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full +C column rank in the pencil s*E(eps,inf)-A(eps,inf). +C On exit, this array contains the column dimensions mu(k), +C (k=1, 2, ..., NBLCKS) of the submatrices having full +C column rank in the pencil s*E(eps)-A(eps). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, this array contains the matrix A to be reduced. +C On exit, it contains the transformed matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, this array contains the matrix E to be reduced. +C On exit, it contains the transformed matrix E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,M). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,*) +C On entry, if UPDATQ = .TRUE., then the leading M-by-M +C part of this array must contain a given matrix Q (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading M-by-M part of this array contains the +C product of the input matrix Q and the row transformation +C matrix that has transformed the rows of the matrices A +C and E. +C If UPDATQ = .FALSE., the array Q is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDQ = 1 and declare this array to be Q(1,1) in the calling +C program). +C +C LDQ INTEGER +C The leading dimension of array Q. If UPDATQ = .TRUE., +C LDQ >= MAX(1,M); if UPDATQ = .FALSE., LDQ >= 1. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,*) +C On entry, if UPDATZ = .TRUE., then the leading N-by-N +C part of this array must contain a given matrix Z (e.g. +C from a previous call to another SLICOT routine), and on +C exit, the leading N-by-N part of this array contains the +C product of the input matrix Z and the column +C transformation matrix that has transformed the columns of +C the matrices A and E. +C If UPDATZ = .FALSE., the array Z is not referenced and +C can be supplied as a dummy array (i.e. set parameter +C LDZ = 1 and declare this array to be Z(1,1) in the calling +C program). +C +C LDZ INTEGER +C The leading dimension of array Z. If UPDATZ = .TRUE., +C LDZ >= MAX(1,N); if UPDATZ = .FALSE., LDZ >= 1. +C +C MNEI (output) INTEGER array, dimension (3) +C MNEI(1) = MEPS = row dimension of sE(eps)-A(eps); +C MNEI(2) = NEPS = column dimension of sE(eps)-A(eps); +C MNEI(3) = MINF = order of the regular pencil +C sE(inf)-A(inf). +C +C REFERENCES +C +C [1] Beelen, Th. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, +C The Netherlands, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Based on Release 3.0 routine MB04TX modified by A. Varga, +C German Aerospace Research Establishment, Oberpfaffenhofen, +C Germany, Nov. 1997, as follows: +C 1) NBLCKS is only an input variable; +C 2) the significance of MNEI is changed. +C +C REVISIONS +C +C A. Varga, DLR Oberpfaffenhofen, March 2002. +C +C KEYWORDS +C +C Generalized eigenvalue problem, Kronecker indices, orthogonal +C transformation, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL UPDATQ, UPDATZ + INTEGER LDA, LDE, LDQ, LDZ, M, N, NBLCKS +C .. Array Arguments .. + INTEGER IMUK(*), INUK(*), MNEI(3) + DOUBLE PRECISION A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER CA, CJA, CJE, IP, ISMUK, ISNUK, K, MEPS, MINF, + $ MUK, MUKP1, MUP, MUP1, NEPS, NUK, NUP, RA, RJE, + $ SK1P1, TK1P1, TP1 + DOUBLE PRECISION SC, SS +C .. External Subroutines .. + EXTERNAL DROTG, MB04TU +C .. Executable Statements .. +C + MNEI(1) = 0 + MNEI(2) = 0 + MNEI(3) = 0 + IF ( M.LE.0 .OR. N.LE.0 ) + $ RETURN +C +C Initialisation. +C + ISMUK = 0 + ISNUK = 0 +C + DO 20 K = 1, NBLCKS + ISMUK = ISMUK + IMUK(K) + ISNUK = ISNUK + INUK(K) + 20 CONTINUE +C +C MEPS, NEPS are the dimensions of the pencil s*E(eps)-A(eps). +C MEPS = Sum(k=1,...,nblcks) NU(k), +C NEPS = Sum(k=1,...,nblcks) MU(k). +C MINF is the order of the regular pencil s*E(inf)-A(inf). +C + MEPS = ISNUK + NEPS = ISMUK + MINF = 0 +C +C MUKP1 = mu(k+1). N.B. It is assumed that mu(NBLCKS + 1) = 0. +C + MUKP1 = 0 +C + DO 120 K = NBLCKS, 1, -1 + NUK = INUK(K) + MUK = IMUK(K) +C +C Reduce submatrix E(k,k+1) to square matrix. +C NOTE that always NU(k) >= MU(k+1) >= 0. +C +C WHILE ( NU(k) > MU(k+1) ) DO + 40 IF ( NUK.GT.MUKP1 ) THEN +C +C sk1p1 = sum(i=k+1,...,p-1) NU(i) +C tk1p1 = sum(i=k+1,...,p-1) MU(i) +C ismuk = sum(i=1,...,k) MU(i) +C tp1 = sum(i=1,...,p-1) MU(i) = ismuk + tk1p1. +C + SK1P1 = 0 + TK1P1 = 0 +C + DO 100 IP = K + 1, NBLCKS +C +C Annihilate the elements originally present in the last +C row of E(k,p+1) and A(k,p). +C Start annihilating the first MU(p) - MU(p+1) elements by +C applying column Givens rotations plus interchanging +C elements. +C Use original bottom diagonal element of A(k,k) as pivot. +C Start position of pivot in A = (ra,ca). +C + TP1 = ISMUK + TK1P1 + RA = ISNUK + SK1P1 + CA = TP1 +C + MUP = IMUK(IP) + NUP = INUK(IP) + MUP1 = NUP +C + DO 60 CJA = CA, CA + MUP - NUP - 1 +C +C CJA = current column index of pivot in A. +C + CALL DROTG( A(RA,CJA), A(RA,CJA+1), SC, SS ) +C +C Apply transformations to A- and E-matrix. +C Interchange columns simultaneously. +C Update column transformation matrix Z, if needed. +C + CALL MB04TU( RA-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, + $ SS ) + A(RA,CJA+1) = A(RA,CJA) + A(RA,CJA) = ZERO + CALL MB04TU( RA, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) + IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), + $ 1, SC, SS ) + 60 CONTINUE +C +C Annihilate the remaining elements originally present in +C the last row of E(k,p+1) and A(k,p) by alternatingly +C applying row and column rotations plus interchanging +C elements. +C Use diagonal elements of E(p,p+1) and original bottom +C diagonal element of A(k,k) as pivots, respectively. +C (re,ce) and (ra,ca) are the starting positions of the +C pivots in E and A. +C + CJE = TP1 + MUP + CJA = CJE - MUP1 - 1 +C + DO 80 RJE = RA + 1, RA + MUP1 +C +C (RJE,CJE) = current position pivot in E. +C + CJE = CJE + 1 + CJA = CJA + 1 +C +C Determine the row transformations. +C Apply these transformations to E- and A-matrix. +C Interchange the rows simultaneously. +C Update row transformation matrix Q, if needed. +C + CALL DROTG( E(RJE,CJE), E(RJE-1,CJE), SC, SS ) + CALL MB04TU( N-CJE, E(RJE,CJE+1), LDE, E(RJE-1,CJE+1), + $ LDE, SC, SS ) + E(RJE-1,CJE) = E(RJE,CJE) + E(RJE,CJE) = ZERO + CALL MB04TU( N-CJA+1, A(RJE,CJA), LDA, A(RJE-1,CJA), + $ LDA, SC, SS ) + IF( UPDATQ ) CALL MB04TU( M, Q(1,RJE), 1, + $ Q(1,RJE-1), 1, SC, SS ) +C +C Determine the column transformations. +C Apply these transformations to A- and E-matrix. +C Interchange the columns simultaneously. +C Update column transformation matrix Z, if needed. +C + CALL DROTG( A(RJE,CJA), A(RJE,CJA+1), SC, SS ) + CALL MB04TU( RJE-1, A(1,CJA), 1, A(1,CJA+1), 1, SC, + $ SS ) + A(RJE,CJA+1) = A(RJE,CJA) + A(RJE,CJA) = ZERO + CALL MB04TU( RJE, E(1,CJA), 1, E(1,CJA+1), 1, SC, SS ) + IF( UPDATZ ) CALL MB04TU( N, Z(1,CJA), 1, Z(1,CJA+1), + $ 1, SC, SS ) + 80 CONTINUE +C + SK1P1 = SK1P1 + NUP + TK1P1 = TK1P1 + MUP +C + 100 CONTINUE +C +C Reduce A=A(eps,inf) and E=E(eps,inf) by ignoring their last +C row and right most column. The row and column ignored +C belong to the pencil s*E(inf)-A(inf). +C Redefine blocks in new A and E. +C + MUK = MUK - 1 + NUK = NUK - 1 + ISMUK = ISMUK - 1 + ISNUK = ISNUK - 1 + MEPS = MEPS - 1 + NEPS = NEPS - 1 + MINF = MINF + 1 +C + GO TO 40 + END IF +C END WHILE 40 +C + IMUK(K) = MUK + INUK(K) = NUK +C +C Now submatrix E(k,k+1) is square. +C +C Consider next submatrix (k:=k-1). +C + ISNUK = ISNUK - NUK + ISMUK = ISMUK - MUK + MUKP1 = MUK + 120 CONTINUE +C +C Store dimensions of the pencils s*E(eps)-A(eps) and +C s*E(inf)-A(inf) in array MNEI. +C + MNEI(1) = MEPS + MNEI(2) = NEPS + MNEI(3) = MINF +C + RETURN +C *** Last line of MB04VX *** + END diff --git a/mex/sources/libslicot/MB04WD.f b/mex/sources/libslicot/MB04WD.f new file mode 100644 index 000000000..9edbbf8c6 --- /dev/null +++ b/mex/sources/libslicot/MB04WD.f @@ -0,0 +1,411 @@ + SUBROUTINE MB04WD( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, + $ CS, TAU, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate a matrix Q with orthogonal columns (spanning an +C isotropic subspace), which is defined as the first n columns +C of a product of symplectic reflectors and Givens rotators, +C +C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C The matrix Q is returned in terms of its first 2*M rows +C +C [ op( Q1 ) op( Q2 ) ] +C Q = [ ]. +C [ -op( Q2 ) op( Q1 ) ] +C +C Blocked version of the SLICOT Library routine MB04WU. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANQ1 CHARACTER*1 +C Specifies the form of op( Q1 ) as follows: +C = 'N': op( Q1 ) = Q1; +C = 'T': op( Q1 ) = Q1'; +C = 'C': op( Q1 ) = Q1'. +C +C TRANQ2 CHARACTER*1 +C Specifies the form of op( Q2 ) as follows: +C = 'N': op( Q2 ) = Q2; +C = 'T': op( Q2 ) = Q2'; +C = 'C': op( Q2 ) = Q2'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices Q1 and Q2. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices Q1 and Q2. +C M >= N >= 0. +C +C K (input) INTEGER +C The number of symplectic Givens rotators whose product +C partly defines the matrix Q. N >= K >= 0. +C +C Q1 (input/output) DOUBLE PRECISION array, dimension +C (LDQ1,N) if TRANQ1 = 'N', +C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' +C On entry with TRANQ1 = 'N', the leading M-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector F(i). +C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading +C K-by-M part of this array must contain in its i-th row +C the vector which defines the elementary reflector F(i). +C On exit with TRANQ1 = 'N', the leading M-by-N part of this +C array contains the matrix Q1. +C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading +C N-by-M part of this array contains the matrix Q1'. +C +C LDQ1 INTEGER +C The leading dimension of the array Q1. +C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; +C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. +C +C Q2 (input/output) DOUBLE PRECISION array, dimension +C (LDQ2,N) if TRANQ2 = 'N', +C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' +C On entry with TRANQ2 = 'N', the leading M-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector H(i) and, on the +C diagonal, the scalar factor of H(i). +C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading +C K-by-M part of this array must contain in its i-th row the +C vector which defines the elementary reflector H(i) and, on +C the diagonal, the scalar factor of H(i). +C On exit with TRANQ2 = 'N', the leading M-by-N part of this +C array contains the matrix Q2. +C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading +C N-by-M part of this array contains the matrix Q2'. +C +C LDQ2 INTEGER +C The leading dimension of the array Q2. +C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; +C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK, MAX(M+N,8*N*NB + 15*NB*NB), where NB is +C the optimal block size determined by the function UE01MD. +C On exit, if INFO = -13, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,M+N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSB). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANQ1, TRANQ2 + INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) +C .. Local Scalars .. + LOGICAL LTRQ1, LTRQ2 + INTEGER I, IB, IERR, KI, KK, NB, NBMIN, NX, PDRS, PDT, + $ PDW, WRKOPT +C .. External Functions .. + LOGICAL LSAME + INTEGER UE01MD + EXTERNAL LSAME, UE01MD +C .. External Subroutines .. + EXTERNAL MB04QC, MB04QF, MB04WU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LTRQ1 = LSAME( TRANQ1, 'T' ) .OR. LSAME( TRANQ1,'C' ) + LTRQ2 = LSAME( TRANQ2, 'T' ) .OR. LSAME( TRANQ2,'C' ) + NB = UE01MD( 1, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( M.LT.0 ) THEN + INFO = -3 + ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN + INFO = -4 + ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN + INFO = -5 + ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN + INFO = -9 + ELSE IF ( LDWORK.LT.MAX( 1, M + N ) ) THEN + DWORK(1) = DBLE( MAX( 1, M + N ) ) + INFO = -13 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + NBMIN = 2 + NX = 0 + WRKOPT = M + N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +C +C Determine when to cross over from blocked to unblocked code. +C + NX = MAX( 0, UE01MD( 3, 'MB04WD', TRANQ1 // TRANQ2, M, N, K ) ) + IF ( NX.LT.K ) THEN +C +C Determine if workspace is large enough for blocked code. +C + WRKOPT = MAX( WRKOPT, 8*N*NB + 15*NB*NB ) + IF( LDWORK.LT.WRKOPT ) THEN +C +C Not enough workspace to use optimal NB: reduce NB and +C determine the minimum value of NB. +C + NB = INT( ( SQRT( DBLE( 16*N*N + 15*LDWORK ) ) + $ - DBLE( 4*N ) ) / 15.0D0 ) + NBMIN = MAX( 2, UE01MD( 2, 'MB04WD', TRANQ1 // TRANQ2, M, + $ N, K ) ) + END IF + END IF + END IF +C + IF ( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +C +C Use blocked code after the last block. +C The first kk columns are handled by the block method. +C + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) + ELSE + KK = 0 + END IF +C +C Use unblocked code for the last or only block. +C + IF ( KK.LT.N ) + $ CALL MB04WU( TRANQ1, TRANQ2, M-KK, N-KK, K-KK, Q1(KK+1,KK+1), + $ LDQ1, Q2(KK+1,KK+1), LDQ2, CS(2*KK+1), TAU(KK+1), + $ DWORK, LDWORK, IERR ) +C +C Blocked code. +C + IF ( KK.GT.0 ) THEN + PDRS = 1 + PDT = PDRS + 6*NB*NB + PDW = PDT + 9*NB*NB + IF ( LTRQ1.AND.LTRQ2 ) THEN + DO 10 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF ( I+IB.LE.N ) THEN +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', 'Rowwise', 'Rowwise', M-I+1, + $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, + $ DWORK(PDT), NB, DWORK(PDW) ) +C +C Apply SH to Q1(i+ib:n,i:m) and Q2(i+ib:n,i:m) from +C the right. +C + CALL MB04QC( 'Zero Structure', 'Transpose', + $ 'Transpose', 'No Transpose', 'Forward', + $ 'Rowwise', 'Rowwise', M-I+1, N-I-IB+1, + $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ DWORK(PDRS), NB, DWORK(PDT), NB, + $ Q2(I+IB,I), LDQ2, Q1(I+IB,I), LDQ1, + $ DWORK(PDW) ) + END IF +C +C Apply SH to columns i:m of the current block. +C + CALL MB04WU( 'Transpose', 'Transpose', M-I+1, IB, IB, + $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ TAU(I), DWORK, LDWORK, IERR ) + 10 CONTINUE +C + ELSE IF ( LTRQ1 ) THEN + DO 20 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF ( I+IB.LE.N ) THEN +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', 'Rowwise', 'Columnwise', + $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, + $ DWORK(PDT), NB, DWORK(PDW) ) +C +C Apply SH to Q1(i+ib:n,i:m) from the right and to +C Q2(i:m,i+ib:n) from the left. +C + CALL MB04QC( 'Zero Structure', 'No Transpose', + $ 'Transpose', 'No Transpose', + $ 'Forward', 'Rowwise', 'Columnwise', + $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, + $ Q2(I,I), LDQ2, DWORK(PDRS), NB, + $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, + $ Q1(I+IB,I), LDQ1, DWORK(PDW) ) + END IF +C +C Apply SH to columns/rows i:m of the current block. +C + CALL MB04WU( 'Transpose', 'No Transpose', M-I+1, IB, IB, + $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ TAU(I), DWORK, LDWORK, IERR ) + 20 CONTINUE +C + ELSE IF ( LTRQ2 ) THEN + DO 30 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF ( I+IB.LE.N ) THEN +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', 'Columnwise', 'Rowwise', + $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, + $ DWORK(PDT), NB, DWORK(PDW) ) +C +C Apply SH to Q1(i:m,i+ib:n) from the left and to +C Q2(i+ib:n,i:m) from the right. +C + CALL MB04QC( 'Zero Structure', 'Transpose', + $ 'No Transpose', 'No Transpose', 'Forward', + $ 'Columnwise', 'Rowwise', M-I+1, N-I-IB+1, + $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ DWORK(PDRS), NB, DWORK(PDT), NB, + $ Q2(I+IB,I), LDQ2, Q1(I,I+IB), LDQ1, + $ DWORK(PDW) ) + END IF +C +C Apply SH to columns/rows i:m of the current block. +C + CALL MB04WU( 'No Transpose', 'Transpose', M-I+1, IB, IB, + $ Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ TAU(I), DWORK, LDWORK, IERR ) + 30 CONTINUE +C + ELSE + DO 40 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF ( I+IB.LE.N ) THEN +C +C Form the triangular factors of the symplectic block +C reflector SH. +C + CALL MB04QF( 'Forward', 'Columnwise', 'Columnwise', + $ M-I+1, IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, + $ CS(2*I-1), TAU(I), DWORK(PDRS), NB, + $ DWORK(PDT), NB, DWORK(PDW) ) +C +C Apply SH to Q1(i:m,i+ib:n) and Q2(i:m,i+ib:n) from +C the left. +C + CALL MB04QC( 'Zero Structure', 'No Transpose', + $ 'No Transpose', 'No Transpose', + $ 'Forward', 'Columnwise', 'Columnwise', + $ M-I+1, N-I-IB+1, IB, Q1(I,I), LDQ1, + $ Q2(I,I), LDQ2, DWORK(PDRS), NB, + $ DWORK(PDT), NB, Q2(I,I+IB), LDQ2, + $ Q1(I,I+IB), LDQ1, DWORK(PDW) ) + END IF +C +C Apply SH to rows i:m of the current block. +C + CALL MB04WU( 'No Transpose', 'No Transpose', M-I+1, IB, + $ IB, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ TAU(I), DWORK, LDWORK, IERR ) + 40 CONTINUE + END IF + END IF +C + DWORK(1) = DBLE( WRKOPT ) +C + RETURN +C *** Last line of MB04WD *** + END diff --git a/mex/sources/libslicot/MB04WP.f b/mex/sources/libslicot/MB04WP.f new file mode 100644 index 000000000..2af3306c6 --- /dev/null +++ b/mex/sources/libslicot/MB04WP.f @@ -0,0 +1,211 @@ + SUBROUTINE MB04WP( N, ILO, U1, LDU1, U2, LDU2, CS, TAU, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate an orthogonal symplectic matrix U, which is defined as +C a product of symplectic reflectors and Givens rotators +C +C U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(n-1),H(n-1) ) G(n-1) diag( F(n-1),F(n-1) ). +C +C as returned by MB04PU. The matrix U is returned in terms of its +C first N rows +C +C [ U1 U2 ] +C U = [ ]. +C [ -U2 U1 ] +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices U1 and U2. N >= 0. +C +C ILO (input) INTEGER +C ILO must have the same value as in the previous call of +C MB04PU. U is equal to the unit matrix except in the +C submatrix +C U([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]). +C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. +C +C U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,N) +C On entry, the leading N-by-N part of this array must +C contain in its i-th column the vector which defines the +C elementary reflector F(i). +C On exit, the leading N-by-N part of this array contains +C the matrix U1. +C +C LDU1 INTEGER +C The leading dimension of the array U1. LDU1 >= MAX(1,N). +C +C U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,N) +C On entry, the leading N-by-N part of this array must +C contain in its i-th column the vector which defines the +C elementary reflector H(i) and, on the subdiagonal, the +C scalar factor of H(i). +C On exit, the leading N-by-N part of this array contains +C the matrix U2. +C +C LDU2 INTEGER +C The leading dimension of the array U2. LDU2 >= MAX(1,N). +C +C CS (input) DOUBLE PRECISION array, dimension (2N-2) +C On entry, the first 2N-2 elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (N-1) +C On entry, the first N-1 elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -10, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,2*(N-ILO)). +C For optimum performance LDWORK should be larger. (See +C SLICOT Library routine MB04WD). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O(N**3) floating point operations and is +C strongly backward stable. +C +C REFERENCES +C +C [1] C. F. VAN LOAN: +C A symplectic method for approximating all the eigenvalues of +C a Hamiltonian matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] D. KRESSNER: +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner (Technical Univ. Berlin, Germany) and +C P. Benner (Technical Univ. Chemnitz, Germany), December 2003. +C +C REVISIONS +C +C V. Sima, Nov. 2008 (SLICOT version of the HAPACK routine DOSGPV). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + INTEGER ILO, INFO, LDU1, LDU2, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), U1(LDU1,*), U2(LDU2,*), TAU(*) +C .. Local Scalars .. + INTEGER I, IERR, J, NH +C .. External Subroutines .. + EXTERNAL DLASET, MB04WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF ( LDU1.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDU2.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDWORK.LT.MAX( 1, 2*( N - ILO ) ) ) THEN + DWORK(1) = DBLE( MAX( 1, 2*( N - ILO ) ) ) + INFO = -10 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04WP', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Shift the vectors which define the elementary reflectors one +C column to the right, and set the first ilo rows and columns to +C those of the unit matrix. +C + DO 30 J = N, ILO + 1, -1 + DO 10 I = 1, J-1 + U1(I,J) = ZERO + 10 CONTINUE + DO 20 I = J+1, N + U1(I,J) = U1(I,J-1) + 20 CONTINUE + 30 CONTINUE + CALL DLASET( 'All', N, ILO, ZERO, ONE, U1, LDU1 ) + DO 60 J = N, ILO + 1, -1 + DO 40 I = 1, J-1 + U2(I,J) = ZERO + 40 CONTINUE + DO 50 I = J, N + U2(I,J) = U2(I,J-1) + 50 CONTINUE + 60 CONTINUE + CALL DLASET( 'All', N, ILO, ZERO, ZERO, U2, LDU2 ) + NH = N - ILO + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, + $ U1(ILO+1,ILO+1), LDU1, U2(ILO+1,ILO+1), LDU2, + $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) + END IF + RETURN +C *** Last line of MB04WP *** + END diff --git a/mex/sources/libslicot/MB04WR.f b/mex/sources/libslicot/MB04WR.f new file mode 100644 index 000000000..42c1f461b --- /dev/null +++ b/mex/sources/libslicot/MB04WR.f @@ -0,0 +1,340 @@ + SUBROUTINE MB04WR( JOB, TRANS, N, ILO, Q1, LDQ1, Q2, LDQ2, CS, + $ TAU, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate orthogonal symplectic matrices U or V, defined as +C products of symplectic reflectors and Givens rotators +C +C U = diag( HU(1),HU(1) ) GU(1) diag( FU(1),FU(1) ) +C diag( HU(2),HU(2) ) GU(2) diag( FU(2),FU(2) ) +C .... +C diag( HU(n),HU(n) ) GU(n) diag( FU(n),FU(n) ), +C +C V = diag( HV(1),HV(1) ) GV(1) diag( FV(1),FV(1) ) +C diag( HV(2),HV(2) ) GV(2) diag( FV(2),FV(2) ) +C .... +C diag( HV(n-1),HV(n-1) ) GV(n-1) diag( FV(n-1),FV(n-1) ), +C +C as returned by the SLICOT Library routines MB04TS or MB04TB. The +C matrices U and V are returned in terms of their first N/2 rows: +C +C [ U1 U2 ] [ V1 V2 ] +C U = [ ], V = [ ]. +C [ -U2 U1 ] [ -V2 V1 ] +C +C ARGUMENTS +C +C Input/Output Parameters +C +C JOB CHARACTER*1 +C Specifies whether the matrix U or the matrix V is +C required: +C = 'U': generate U; +C = 'V': generate V. +C +C TRANS CHARACTER*1 +C If JOB = 'U' then TRANS must have the same value as +C the argument TRANA in the previous call of MB04TS or +C MB04TB. +C If JOB = 'V' then TRANS must have the same value as +C the argument TRANB in the previous call of MB04TS or +C MB04TB. +C +C N (input) INTEGER +C The order of the matrices Q1 and Q2. N >= 0. +C +C ILO (input) INTEGER +C ILO must have the same value as in the previous call of +C MB04TS or MB04TB. U and V are equal to the unit matrix +C except in the submatrices +C U([ilo:n n+ilo:2*n], [ilo:n n+ilo:2*n]) and +C V([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]), +C respectively. +C 1 <= ILO <= N, if N > 0; ILO = 1, if N = 0. +C +C Q1 (input/output) DOUBLE PRECISION array, dimension (LDQ1,N) +C On entry, if JOB = 'U' and TRANS = 'N' then the +C leading N-by-N part of this array must contain in its i-th +C column the vector which defines the elementary reflector +C FU(i). +C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the +C leading N-by-N part of this array must contain in its i-th +C row the vector which defines the elementary reflector +C FU(i). +C If JOB = 'V' and TRANS = 'N' then the leading N-by-N +C part of this array must contain in its i-th row the vector +C which defines the elementary reflector FV(i). +C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the +C leading N-by-N part of this array must contain in its i-th +C column the vector which defines the elementary reflector +C FV(i). +C On exit, if JOB = 'U' and TRANS = 'N' then the leading +C N-by-N part of this array contains the matrix U1. +C If JOB = 'U' and TRANS = 'T' or TRANS = 'C' then the +C leading N-by-N part of this array contains the matrix +C U1**T. +C If JOB = 'V' and TRANS = 'N' then the leading N-by-N +C part of this array contains the matrix V1**T. +C If JOB = 'V' and TRANS = 'T' or TRANS = 'C' then the +C leading N-by-N part of this array contains the matrix V1. +C +C LDQ1 INTEGER +C The leading dimension of the array Q1. LDQ1 >= MAX(1,N). +C +C Q2 (input/output) DOUBLE PRECISION array, dimension (LDQ2,N) +C On entry, if JOB = 'U' then the leading N-by-N part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector HU(i). +C If JOB = 'V' then the leading N-by-N part of this array +C must contain in its i-th row the vector which defines the +C elementary reflector HV(i). +C On exit, if JOB = 'U' then the leading N-by-N part of +C this array contains the matrix U2. +C If JOB = 'V' then the leading N-by-N part of this array +C contains the matrix V2**T. +C +C LDQ2 INTEGER +C The leading dimension of the array Q2. LDQ2 >= MAX(1,N). +C +C CS (input) DOUBLE PRECISION array, dimension (2N) +C On entry, if JOB = 'U' then the first 2N elements of +C this array must contain the cosines and sines of the +C symplectic Givens rotators GU(i). +C If JOB = 'V' then the first 2N-2 elements of this array +C must contain the cosines and sines of the symplectic +C Givens rotators GV(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (N) +C On entry, if JOB = 'U' then the first N elements of +C this array must contain the scalar factors of the +C elementary reflectors FU(i). +C If JOB = 'V' then the first N-1 elements of this array +C must contain the scalar factors of the elementary +C reflectors FV(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -12, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,2*(N-ILO+1)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Benner, P., Mehrmann, V., and Xu, H. +C A numerically stable, structure preserving method for +C computing the eigenvalues of real Hamiltonian or symplectic +C pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998. +C +C [2] Kressner, D. +C Block algorithms for orthogonal symplectic factorizations. +C BIT, 43 (4), pp. 775-790, 2003. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSU). +C +C KEYWORDS +C +C Elementary matrix operations, Hamiltonian matrix, orthogonal +C symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER JOB, TRANS + INTEGER ILO, INFO, LDQ1, LDQ2, LDWORK, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) +C .. Local Scalars .. + LOGICAL COMPU, LTRAN + INTEGER I, IERR, J, NH +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLASET, MB04WD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) + COMPU = LSAME( JOB, 'U' ) + IF ( .NOT.COMPU .AND. .NOT.LSAME( JOB, 'V' ) ) THEN + INFO = -1 + ELSE IF ( .NOT.LTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -2 + ELSE IF ( N.LT.0 ) THEN + INFO = -3 + ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDQ1.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDQ2.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF ( LDWORK.LT.MAX( 1, 2*( N-ILO+1 ) ) ) THEN + DWORK(1) = DBLE( MAX( 1, 2*( N-ILO+1 ) ) ) + INFO = -12 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04WR', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + IF ( COMPU ) THEN + CALL DLASET( 'All', N, ILO-1, ZERO, ONE, Q1, LDQ1 ) + CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q1(1,ILO), + $ LDQ1 ) + CALL DLASET( 'All', N, ILO-1, ZERO, ZERO, Q2, LDQ2 ) + CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q2(1,ILO), + $ LDQ2 ) + NH = N - ILO + 1 + END IF + IF ( COMPU .AND. .NOT.LTRAN ) THEN +C +C Generate U1 and U2. +C + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH, + $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), + $ TAU(ILO), DWORK, LDWORK, IERR ) + END IF + ELSE IF ( COMPU.AND.LTRAN ) THEN +C +C Generate U1**T and U2. +C + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'Transpose', 'No Transpose', NH, NH, NH, + $ Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO), + $ TAU(ILO), DWORK, LDWORK, IERR ) + END IF + ELSE IF ( .NOT.COMPU .AND. .NOT.LTRAN ) THEN +C +C Generate V1**T and V2**T. +C +C Shift the vectors which define the elementary reflectors one +C column to the bottom, and set the first ilo rows and +C columns to those of the unit matrix. +C + DO 40 I = 1, N + DO 10 J = N, MAX( I, ILO )+1, -1 + Q1(J,I) = ZERO + 10 CONTINUE + DO 20 J = MAX( I, ILO ), ILO+1, -1 + Q1(J,I) = Q1(J-1,I) + 20 CONTINUE + DO 30 J = ILO, 1, -1 + Q1(J,I) = ZERO + 30 CONTINUE + IF ( I.LE.ILO ) Q1(I,I) = ONE + 40 CONTINUE + DO 80 I = 1, N + DO 50 J = N, MAX( I, ILO )+1, -1 + Q2(J,I) = ZERO + 50 CONTINUE + DO 60 J = MAX( I, ILO ), ILO+1, -1 + Q2(J,I) = Q2(J-1,I) + 60 CONTINUE + DO 70 J = ILO, 1, -1 + Q2(J,I) = ZERO + 70 CONTINUE + 80 CONTINUE +C + NH = N - ILO + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'Transpose', 'Transpose', NH, NH, NH, + $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, + $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) + END IF + ELSE IF ( .NOT.COMPU .AND. LTRAN ) THEN +C +C Generate V1 and V2**T. +C +C Shift the vectors which define the elementary reflectors one +C column to the right/bottom, and set the first ilo rows and +C columns to those of the unit matrix. +C + DO 110 J = N, ILO + 1, -1 + DO 90 I = 1, J-1 + Q1(I,J) = ZERO + 90 CONTINUE + DO 100 I = J+1, N + Q1(I,J) = Q1(I,J-1) + 100 CONTINUE + 110 CONTINUE + CALL DLASET( 'All', N, ILO, ZERO, ONE, Q1, LDQ1 ) + DO 150 I = 1, N + DO 120 J = N, MAX( I, ILO )+1, -1 + Q2(J,I) = ZERO + 120 CONTINUE + DO 130 J = MAX( I, ILO ), ILO+1, -1 + Q2(J,I) = Q2(J-1,I) + 130 CONTINUE + DO 140 J = ILO, 1, -1 + Q2(J,I) = ZERO + 140 CONTINUE + 150 CONTINUE + NH = N - ILO +C + IF ( NH.GT.0 ) THEN + CALL MB04WD( 'No Transpose', 'Transpose', NH, NH, NH, + $ Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2, + $ CS(ILO), TAU(ILO), DWORK, LDWORK, IERR ) + END IF + END IF + RETURN +C *** Last line of MB04WR *** + END diff --git a/mex/sources/libslicot/MB04WU.f b/mex/sources/libslicot/MB04WU.f new file mode 100644 index 000000000..1e177810b --- /dev/null +++ b/mex/sources/libslicot/MB04WU.f @@ -0,0 +1,402 @@ + SUBROUTINE MB04WU( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2, + $ CS, TAU, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To generate a matrix Q with orthogonal columns (spanning an +C isotropic subspace), which is defined as the first n columns +C of a product of symplectic reflectors and Givens rotators, +C +C Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) ) +C diag( H(2),H(2) ) G(2) diag( F(2),F(2) ) +C .... +C diag( H(k),H(k) ) G(k) diag( F(k),F(k) ). +C +C The matrix Q is returned in terms of its first 2*M rows +C +C [ op( Q1 ) op( Q2 ) ] +C Q = [ ]. +C [ -op( Q2 ) op( Q1 ) ] +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANQ1 CHARACTER*1 +C Specifies the form of op( Q1 ) as follows: +C = 'N': op( Q1 ) = Q1; +C = 'T': op( Q1 ) = Q1'; +C = 'C': op( Q1 ) = Q1'. +C +C TRANQ2 CHARACTER*1 +C Specifies the form of op( Q2 ) as follows: +C = 'N': op( Q2 ) = Q2; +C = 'T': op( Q2 ) = Q2'; +C = 'C': op( Q2 ) = Q2'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrices Q1 and Q2. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrices Q1 and Q2. +C M >= N >= 0. +C +C K (input) INTEGER +C The number of symplectic Givens rotators whose product +C partly defines the matrix Q. N >= K >= 0. +C +C Q1 (input/output) DOUBLE PRECISION array, dimension +C (LDQ1,N) if TRANQ1 = 'N', +C (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C' +C On entry with TRANQ1 = 'N', the leading M-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector F(i). +C On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading +C K-by-M part of this array must contain in its i-th row +C the vector which defines the elementary reflector F(i). +C On exit with TRANQ1 = 'N', the leading M-by-N part of this +C array contains the matrix Q1. +C On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading +C N-by-M part of this array contains the matrix Q1'. +C +C LDQ1 INTEGER +C The leading dimension of the array Q1. +C LDQ1 >= MAX(1,M), if TRANQ1 = 'N'; +C LDQ1 >= MAX(1,N), if TRANQ1 = 'T' or TRANQ1 = 'C'. +C +C Q2 (input/output) DOUBLE PRECISION array, dimension +C (LDQ2,N) if TRANQ2 = 'N', +C (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C' +C On entry with TRANQ2 = 'N', the leading M-by-K part of +C this array must contain in its i-th column the vector +C which defines the elementary reflector H(i) and, on the +C diagonal, the scalar factor of H(i). +C On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading +C K-by-M part of this array must contain in its i-th row the +C vector which defines the elementary reflector H(i) and, on +C the diagonal, the scalar factor of H(i). +C On exit with TRANQ2 = 'N', the leading M-by-N part of this +C array contains the matrix Q2. +C On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading +C N-by-M part of this array contains the matrix Q2'. +C +C LDQ2 INTEGER +C The leading dimension of the array Q2. +C LDQ2 >= MAX(1,M), if TRANQ2 = 'N'; +C LDQ2 >= MAX(1,N), if TRANQ2 = 'T' or TRANQ2 = 'C'. +C +C CS (input) DOUBLE PRECISION array, dimension (2*K) +C On entry, the first 2*K elements of this array must +C contain the cosines and sines of the symplectic Givens +C rotators G(i). +C +C TAU (input) DOUBLE PRECISION array, dimension (K) +C On entry, the first K elements of this array must +C contain the scalar factors of the elementary reflectors +C F(i). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C On exit, if INFO = -13, DWORK(1) returns the minimum +C value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,M+N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C REFERENCES +C +C [1] Bunse-Gerstner, A. +C Matrix factorizations for symplectic QR-like methods. +C Linear Algebra Appl., 83, pp. 49-77, 1986. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSQ). +C +C KEYWORDS +C +C Elementary matrix operations, orthogonal symplectic matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANQ1, TRANQ2 + INTEGER INFO, K, LDQ1, LDQ2, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*) +C .. Local Scalars .. + LOGICAL LTRQ1, LTRQ2 + INTEGER I, J + DOUBLE PRECISION NU +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARF, DLASET, DROT, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INFO = 0 + LTRQ1 = LSAME( TRANQ1,'T' ) .OR. LSAME( TRANQ1,'C' ) + LTRQ2 = LSAME( TRANQ2,'T' ) .OR. LSAME( TRANQ2,'C' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN + INFO = -1 + ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN + INFO = -2 + ELSE IF ( M.LT.0 ) THEN + INFO = -3 + ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN + INFO = -4 + ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN + INFO = -5 + ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN + INFO = -9 + ELSE IF ( LDWORK.LT.MAX( 1,M + N ) ) THEN + DWORK(1) = DBLE( MAX( 1,M + N ) ) + INFO = -13 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04WU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Initialize columns K+1:N to columns of the unit matrix. +C + DO 20 J = K + 1, N + DO 10 I = 1, M + Q1(I,J) = ZERO + 10 CONTINUE + Q1(J,J) = ONE + 20 CONTINUE + CALL DLASET( 'All', M, N-K, ZERO, ZERO, Q2(1,K+1), LDQ2 ) +C + IF ( LTRQ1.AND.LTRQ2 ) THEN + DO 50 I = K, 1, -1 +C +C Apply F(I) to Q1(I+1:N,I:M) and Q2(I+1:N,I:M) from the +C right. +C + CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) + IF ( I.LT.N ) THEN + Q1(I,I) = ONE + CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), + $ Q1(I+1,I), LDQ1, DWORK(M+1) ) + CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), + $ Q2(I+1,I), LDQ2, DWORK(M+1) ) + END IF + IF ( I.LT.M ) + $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) + Q1(I,I) = ONE - TAU(I) +C +C Set Q1(I,1:I-1) and Q2(I,1:M) to zero. +C + DO 30 J = 1, I - 1 + Q1(I,J) = ZERO + 30 CONTINUE + DO 40 J = 1, M + Q2(I,J) = ZERO + 40 CONTINUE +C +C Apply G(I) to Q1(I:N,I) and Q2(I:N,I) from the right. +C + CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), 1, CS(2*I-1), + $ CS(2*I) ) +C +C Apply H(I) to Q1(I:N,I:M) and Q2(I:N,I:M) from the right. +C + NU = DWORK(1) + DWORK(1) = ONE + CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), + $ LDQ1, DWORK(M+1) ) + CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), + $ LDQ2, DWORK(M+1) ) + 50 CONTINUE + ELSE IF ( LTRQ1 ) THEN + DO 80 I = K, 1, -1 +C +C Apply F(I) to Q1(I+1:N,I:M) from the right and to +C Q2(I:M,I+1:N) from the left. +C + CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) + IF ( I.LT.N ) THEN + Q1(I,I) = ONE + CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I), + $ Q1(I+1,I), LDQ1, DWORK(M+1) ) + CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), LDQ1, TAU(I), + $ Q2(I,I+1), LDQ2, DWORK(M+1) ) + END IF + IF ( I.LT.M ) + $ CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 ) + Q1(I,I) = ONE - TAU(I) +C +C Set Q1(I,1:I-1) and Q2(1:M,I) to zero. +C + DO 60 J = 1, I - 1 + Q1(I,J) = ZERO + 60 CONTINUE + DO 70 J = 1, M + Q2(J,I) = ZERO + 70 CONTINUE +C +C Apply G(I) to Q1(I:N,I) from the right and to Q2(I,I:N) +C from the left. +C + CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), LDQ2, CS(2*I-1), + $ CS(2*I) ) +C +C Apply H(I) to Q1(I:N,I:M) from the right and to Q2(I:M,I:N) +C from the left. +C + NU = DWORK(1) + DWORK(1) = ONE + CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I), + $ LDQ1, DWORK(M+1) ) + CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), + $ LDQ2, DWORK(M+1) ) + 80 CONTINUE + ELSE IF ( LTRQ2 ) THEN + DO 110 I = K, 1, -1 +C +C Apply F(I) to Q1(I:M,I+1:N) from the left and to +C Q2(I+1:N,I:M) from the right. +C + CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 ) + IF ( I.LT.N ) THEN + Q1(I,I) = ONE + CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), + $ Q1(I,I+1), LDQ1, DWORK(M+1) ) + CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), 1, TAU(I), + $ Q2(I+1,I), LDQ2, DWORK(M+1) ) + END IF + IF ( I.LT.M ) + $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) + Q1(I,I) = ONE - TAU(I) +C +C Set Q1(1:I-1,I) and Q2(I,1:M) to zero. +C + DO 90 J = 1, I - 1 + Q1(J,I) = ZERO + 90 CONTINUE + DO 100 J = 1, M + Q2(I,J) = ZERO + 100 CONTINUE +C +C Apply G(I) to Q1(I,I:N) from the left and to Q2(I:N,I) +C from the right. +C + CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), 1, CS(2*I-1), + $ CS(2*I) ) +C +C Apply H(I) to Q1(I:M,I:N) from the left and to Q2(I:N,I:M) +C from the left. +C + NU = DWORK(1) + DWORK(1) = ONE + CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), + $ LDQ1, DWORK(M+1) ) + CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I), + $ LDQ2, DWORK(M+1) ) + 110 CONTINUE + ELSE + DO 140 I = K, 1, -1 +C +C Apply F(I) to Q1(I:M,I+1:N) and Q2(I:M,I+1:N) from the left. +C + CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 ) + IF ( I.LT.N ) THEN + Q1(I,I) = ONE + CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), + $ Q1(I,I+1), LDQ1, DWORK(M+1) ) + CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I), + $ Q2(I,I+1), LDQ2, DWORK(M+1) ) + END IF + IF ( I.LT.M ) + $ CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 ) + Q1(I,I) = ONE - TAU(I) +C +C Set Q1(1:I-1,I) and Q2(1:M,I) to zero. +C + DO 120 J = 1, I - 1 + Q1(J,I) = ZERO + 120 CONTINUE + DO 130 J = 1, M + Q2(J,I) = ZERO + 130 CONTINUE +C +C Apply G(I) to Q1(I,I:N) and Q2(I,I:N) from the left. +C + CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1), + $ CS(2*I) ) +C +C Apply H(I) to Q1(I:M,I:N) and Q2(I:M,I:N) from the left. +C + NU = DWORK(1) + DWORK(1) = ONE + CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I), + $ LDQ1, DWORK(M+1) ) + CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I), + $ LDQ2, DWORK(M+1) ) + 140 CONTINUE + END IF + DWORK(1) = DBLE( MAX( 1, M+N ) ) +C *** Last line of MB04WU *** + END diff --git a/mex/sources/libslicot/MB04XD.f b/mex/sources/libslicot/MB04XD.f new file mode 100644 index 000000000..6d417486a --- /dev/null +++ b/mex/sources/libslicot/MB04XD.f @@ -0,0 +1,652 @@ + SUBROUTINE MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, + $ V, LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a basis for the left and/or right singular subspace of +C an M-by-N matrix A corresponding to its smallest singular values. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Specifies whether to compute the left singular subspace +C as follows: +C = 'N': Do not compute the left singular subspace; +C = 'A': Return the (M - RANK) base vectors of the desired +C left singular subspace in U; +C = 'S': Return the first (min(M,N) - RANK) base vectors +C of the desired left singular subspace in U. +C +C JOBV CHARACTER*1 +C Specifies whether to compute the right singular subspace +C as follows: +C = 'N': Do not compute the right singular subspace; +C = 'A': Return the (N - RANK) base vectors of the desired +C right singular subspace in V; +C = 'S': Return the first (min(M,N) - RANK) base vectors +C of the desired right singular subspace in V. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns in matrix A. N >= 0. +C +C RANK (input/output) INTEGER +C On entry, if RANK < 0, then the rank of matrix A is +C computed by the routine as the number of singular values +C greater than THETA. +C Otherwise, RANK must specify the rank of matrix A. +C RANK <= min(M,N). +C On exit, if RANK < 0 on entry, then RANK contains the +C computed rank of matrix A. That is, the number of singular +C values of A greater than THETA. +C Otherwise, the user-supplied value of RANK may be changed +C by the routine on exit if the RANK-th and the (RANK+1)-th +C singular values of A are considered to be equal. +C See also the description of parameter TOL below. +C +C THETA (input/output) DOUBLE PRECISION +C On entry, if RANK < 0, then THETA must specify an upper +C bound on the smallest singular values of A corresponding +C to the singular subspace to be computed. THETA >= 0.0. +C Otherwise, THETA must specify an initial estimate (t say) +C for computing an upper bound on the (min(M,N) - RANK) +C smallest singular values of A. If THETA < 0.0, then t is +C computed by the routine. +C On exit, if RANK >= 0 on entry, then THETA contains the +C computed upper bound such that precisely RANK singular +C values of A are greater than THETA + TOL. +C Otherwise, THETA is unchanged. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix A from which the basis of a desired singular +C subspace is to be computed. +C NOTE that this array is destroyed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,M). +C +C U (output) DOUBLE PRECISION array, dimension (LDU,*) +C If JOBU = 'A', then the leading M-by-M part of this array +C contains the (M - RANK) M-dimensional base vectors of the +C desired left singular subspace of A corresponding to its +C singular values less than or equal to THETA. These vectors +C are stored in the i-th column(s) of U for which +C INUL(i) = .TRUE., where i = 1,2,...,M. +C +C If JOBU = 'S', then the leading M-by-min(M,N) part of this +C array contains the first (min(M,N) - RANK) M-dimensional +C base vectors of the desired left singular subspace of A +C corresponding to its singular values less than or equal to +C THETA. These vectors are stored in the i-th column(s) of U +C for which INUL(i) = .TRUE., where i = 1,2,..., min(M,N). +C +C Otherwise, U is not referenced (since JOBU = 'N') and can +C be supplied as a dummy array (i.e. set parameter LDU = 1 +C and declare this array to be U(1,1) in the calling +C program). +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= max(1,M) if JOBU = 'A' or JOBU = 'S', +C LDU >= 1 if JOBU = 'N'. +C +C V (output) DOUBLE PRECISION array, dimension (LDV,*) +C If JOBV = 'A', then the leading N-by-N part of this array +C contains the (N - RANK) N-dimensional base vectors of the +C desired right singular subspace of A corresponding to its +C singular values less than or equal to THETA. These vectors +C are stored in the i-th column(s) of V for which +C INUL(i) = .TRUE., where i = 1,2,...,N. +C +C If JOBV = 'S', then the leading N-by-min(M,N) part of this +C array contains the first (min(M,N) - RANK) N-dimensional +C base vectors of the desired right singular subspace of A +C corresponding to its singular values less than or equal to +C THETA. These vectors are stored in the i-th column(s) of V +C for which INUL(i) = .TRUE., where i = 1,2,...,MIN( M,N). +C +C Otherwise, V is not referenced (since JOBV = 'N') and can +C be supplied as a dummy array (i.e. set parameter LDV = 1 +C and declare this array to be V(1,1) in the calling +C program). +C +C LDV INTEGER +C The leading dimension of array V. +C LDV >= max(1,N) if JOBV = 'A' or JOBV = 'S', +C LDV >= 1 if JOBV = 'N'. +C +C Q (output) DOUBLE PRECISION array, dimension (2*min(M,N)-1) +C This array contains the partially diagonalized bidiagonal +C matrix J computed from A, at the moment that the desired +C singular subspace has been found. Specifically, the +C leading p = min(M,N) entries of Q contain the diagonal +C elements q(1),q(2),...,q(p) and the entries Q(p+1), +C Q(p+2),...,Q(2*p-1) contain the superdiagonal elements +C e(1),e(2),...,e(p-1) of J. +C +C INUL (output) LOGICAL array, dimension (max(M,N)) +C If JOBU <> 'N' or JOBV <> 'N', then the indices of the +C elements of this array with value .TRUE. indicate the +C columns in U and/or V containing the base vectors of the +C desired left and/or right singular subspace of A. They +C also equal the indices of the diagonal elements of the +C bidiagonal submatrices in the array Q, which correspond +C to the computed singular subspaces. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C This parameter defines the multiplicity of singular values +C by considering all singular values within an interval of +C length TOL as coinciding. TOL is used in checking how many +C singular values are less than or equal to THETA. Also in +C computing an appropriate upper bound THETA by a bisection +C method, TOL is used as a stopping criterion defining the +C minimum (absolute) subinterval width. TOL is also taken +C as an absolute tolerance for negligible elements in the +C QR/QL iterations. If the user sets TOL to be less than or +C equal to 0, then the tolerance is taken as specified in +C SLICOT Library routine MB04YD document. +C +C RELTOL DOUBLE PRECISION +C This parameter specifies the minimum relative width of an +C interval. When an interval is narrower than TOL, or than +C RELTOL times the larger (in magnitude) endpoint, then it +C is considered to be sufficiently small and bisection has +C converged. If the user sets RELTOL to be less than +C BASE * EPS, where BASE is machine radix and EPS is machine +C precision (see LAPACK Library routine DLAMCH), then the +C tolerance is taken as BASE * EPS. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = max(1, LDW + max(2*P + max(M,N), LDY)), where +C P = min(M,N); +C LDW = max(2*N, N*(N+1)/2), if JOBU <> 'N' and M large +C enough than N; +C LDW = 0, otherwise; +C LDY = 8*P - 5, if JOBU <> 'N' or JOBV <> 'N'; +C LDY = 6*P - 3, if JOBU = 'N' and JOBV = 'N'. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: if the rank of matrix A (as specified by the user) +C has been lowered because a singular value of +C multiplicity greater than 1 was found. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the maximum number of QR/QL iteration steps +C (30*MIN(M,N)) has been exceeded. +C +C METHOD +C +C The method used is the Partial Singular Value Decomposition (PSVD) +C approach proposed by Van Huffel, Vandewalle and Haegemans, which +C is an efficient technique (see [1]) for computing the singular +C subspace of a matrix corresponding to its smallest singular +C values. It differs from the classical SVD algorithm [3] at three +C points, which results in high efficiency. Firstly, the Householder +C transformations of the bidiagonalization need only to be applied +C on the base vectors of the desired singular subspaces; secondly, +C the bidiagonal matrix need only be partially diagonalized; and +C thirdly, the convergence rate of the iterative diagonalization can +C be improved by an appropriate choice between QL and QR iterations. +C (Note, however, that LAPACK Library routine DGESVD, for computing +C SVD, also uses either QL and QR iterations.) Depending on the gap, +C the desired numerical accuracy and the dimension of the desired +C singular subspace, the PSVD can be up to three times faster than +C the classical SVD algorithm. +C +C The PSVD algorithm [1-2] for an M-by-N matrix A proceeds as +C follows: +C +C Step 1: Bidiagonalization phase +C ----------------------- +C (a) If M is large enough than N, transform A into upper +C triangular form R. +C +C (b) Transform A (or R) into bidiagonal form: +C +C |q(1) e(1) 0 ... 0 | +C (0) | 0 q(2) e(2) . | +C J = | . . | +C | . e(N-1)| +C | 0 ... q(N) | +C +C if M >= N, or +C +C |q(1) 0 0 ... 0 0 | +C (0) |e(1) q(2) 0 . . | +C J = | . . . | +C | . q(M-1) . | +C | 0 ... e(M-1) q(M)| +C +C if M < N, using Householder transformations. +C In the second case, transform the matrix to the upper bidiagonal +C form by applying Givens rotations. +C +C (c) If U is requested, initialize U with the identity matrix. +C If V is requested, initialize V with the identity matrix. +C +C Step 2: Partial diagonalization phase +C ----------------------------- +C If the upper bound THETA is not given, then compute THETA such +C that precisely (min(M,N) - RANK) singular values of the bidiagonal +C matrix are less than or equal to THETA, using a bisection method +C [4]. Diagonalize the given bidiagonal matrix J partially, using +C either QR iterations (if the upper left diagonal element of the +C considered bidiagonal submatrix is larger than the lower right +C diagonal element) or QL iterations, such that J is split into +C unreduced bidiagonal submatrices whose singular values are either +C all larger than THETA or all less than or equal to THETA. +C Accumulate the Givens rotations in U and/or V (if desired). +C +C Step 3: Back transformation phase +C ------------------------- +C (a) Apply the Householder transformations of Step 1(b) onto the +C columns of U and/or V associated with the bidiagonal +C submatrices with all singular values less than or equal to +C THETA (if U and/or V is desired). +C +C (b) If M is large enough than N, and U is desired, then apply the +C Householder transformations of Step 1(a) onto each computed +C column of U in Step 3(a). +C +C REFERENCES +C +C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. +C An efficient and reliable algorithm for computing the singular +C subspace of a matrix associated with its smallest singular +C values. +C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. +C +C [2] Van Huffel, S. +C Analysis of the total least squares problem and its use in +C parameter estimation. +C Doctoral dissertation, Dept. of Electr. Eng., Katholieke +C Universiteit Leuven, Belgium, June 1987. +C +C [3] Chan, T.F. +C An improved algorithm for computing the singular value +C decomposition. +C ACM TOMS, 8, pp. 72-83, 1982. +C +C [4] Van Huffel, S. and Vandewalle, J. +C The partial total least squares algorithm. +C J. Comput. and Appl. Math., 21, pp. 333-341, 1988. +C +C NUMERICAL ASPECTS +C +C Using the PSVD a large reduction in computation time can be +C gained in total least squares applications (cf [2 - 4]), in the +C computation of the null space of a matrix and in solving +C (non)homogeneous linear equations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB04PD by S. Van Huffel, Katholieke +C University Leuven, Belgium. +C +C REVISIONS +C +C July 10, 1997. +C +C KEYWORDS +C +C Bidiagonalization, singular subspace, singular value +C decomposition, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBU, JOBV + INTEGER INFO, IWARN, LDA, LDU, LDV, LDWORK, M, N, RANK + DOUBLE PRECISION RELTOL, THETA, TOL +C .. Array Arguments .. + LOGICAL INUL(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), Q(*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + CHARACTER*1 JOBUY, JOBVY + LOGICAL ALL, LJOBUA, LJOBUS, LJOBVA, LJOBVS, QR, WANTU, + $ WANTV + INTEGER I, IHOUSH, IJ, ITAU, ITAUP, ITAUQ, J, JU, JV, + $ JWORK, K, LDW, LDY, MA, P, PP1, WRKOPT + DOUBLE PRECISION CS, SN, TEMP +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEBRD, DGEQRF, DLARTG, DLASET, DLASR, + $ MB04XY, MB04YD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + P = MIN( M, N ) + K = MAX( M, N ) +C +C Determine whether U and/or V are/is to be computed. +C + LJOBUA = LSAME( JOBU, 'A' ) + LJOBUS = LSAME( JOBU, 'S' ) + LJOBVA = LSAME( JOBV, 'A' ) + LJOBVS = LSAME( JOBV, 'S' ) + WANTU = LJOBUA.OR.LJOBUS + WANTV = LJOBVA.OR.LJOBVS + ALL = ( LJOBUA .AND. M.GT.N ) .OR. ( LJOBVA .AND. M.LT.N ) + QR = M.GE.ILAENV( 6, 'DGESVD', 'N' // 'N', M, N, 0, 0 ) + IF ( QR.AND.WANTU ) THEN + LDW = MAX( 2*N, N*( N + 1 )/2 ) + ELSE + LDW = 0 + END IF + IF ( WANTU.OR.WANTV ) THEN + LDY = 8*P - 5 + ELSE + LDY = 6*P - 3 + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( RANK.GT.P ) THEN + INFO = -5 + ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF( ( .NOT.WANTU .AND. LDU.LT.1 ) .OR. + $ ( WANTU .AND. LDU.LT.MAX( 1, M ) ) ) THEN + INFO = -10 + ELSE IF( ( .NOT.WANTV .AND. LDV.LT.1 ) .OR. + $ ( WANTV .AND. LDV.LT.MAX( 1, N ) ) ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.MAX( 1, LDW + MAX( 2*P + K, LDY ) ) ) THEN + INFO = -18 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04XD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( P.EQ.0 ) THEN + IF ( RANK.GE.0 ) + $ THETA = ZERO + RANK = 0 + RETURN + END IF +C +C Initializations. +C + PP1 = P + 1 +C + IF ( ALL .AND. ( .NOT.QR ) ) THEN +C + DO 20 I = 1, P + INUL(I) = .FALSE. + 20 CONTINUE +C + DO 40 I = PP1, K + INUL(I) = .TRUE. + 40 CONTINUE +C + ELSE +C + DO 60 I = 1, K + INUL(I) = .FALSE. + 60 CONTINUE +C + END IF +C +C Step 1: Bidiagonalization phase +C ----------------------- +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( QR ) THEN +C +C 1.a.: M is large enough than N; transform A into upper +C triangular form R by Householder transformations. +C +C Workspace: need 2*N; prefer N + N*NB. +C + ITAU = 1 + JWORK = ITAU + N + CALL DGEQRF( M, N, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = INT( DWORK(JWORK) )+JWORK-1 +C +C If (WANTU), store information on the Householder +C transformations performed on the columns of A in N*(N+1)/2 +C extra storage locations DWORK(K), for K = 1,2,...,N*(N+1)/2. +C (The first N locations store the scalar factors of Householder +C transformations.) +C +C Workspace: LDW = max(2*N, N*(N+1)/2). +C + IF ( WANTU ) THEN + IHOUSH = JWORK + K = IHOUSH + I = N + ELSE + K = 1 + END IF +C + DO 100 J = 1, N - 1 + IF ( WANTU ) THEN + I = I - 1 + CALL DCOPY( I, A(J+1,J), 1, DWORK(K), 1 ) + K = K + I + END IF +C + DO 80 IJ = J + 1, N + A(IJ,J) = ZERO + 80 CONTINUE +C + 100 CONTINUE +C + MA = N + WRKOPT = MAX( WRKOPT, K ) + ELSE +C +C Workspace: LDW = 0. +C + K = 1 + MA = M + WRKOPT = 1 + END IF +C +C 1.b.: Transform A (or R) into bidiagonal form Q using Householder +C transformations. +C +C Workspace: need LDW + 2*min(M,N) + max(M,N); +C prefer LDW + 2*min(M,N) + (M+N)*NB. +C + ITAUQ = K + ITAUP = ITAUQ + P + JWORK = ITAUP + P + CALL DGEBRD( MA, N, A, LDA, Q, Q(PP1), DWORK(ITAUQ), + $ DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C 1.c.: Initialize U (if WANTU) and V (if WANTV) with the identity +C matrix. +C + IF ( WANTU ) THEN + IF ( ALL ) THEN + JU = M + ELSE + JU = P + END IF + CALL DLASET( 'Full', M, JU, ZERO, ONE, U, LDU ) + JOBUY = 'U' + ELSE + JOBUY = 'N' + END IF + IF ( WANTV ) THEN + IF ( ALL ) THEN + JV = N + ELSE + JV = P + END IF + CALL DLASET( 'Full', N, JV, ZERO, ONE, V, LDV ) + JOBVY = 'U' + ELSE + JOBVY = 'N' + END IF +C +C If the matrix is lower bidiagonal, rotate to be upper bidiagonal +C by applying Givens rotations on the left. +C + IF ( M.LT.N ) THEN +C + DO 120 I = 1, P - 1 + CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP ) + Q(I) = TEMP + Q(P+I) = SN*Q(I+1) + Q(I+1) = CS*Q(I+1) + IF ( WANTU ) THEN +C +C Workspace: LDW + 4*min(M,N) - 2. +C + DWORK(JWORK+I-1) = CS + DWORK(JWORK+P+I-2) = SN + END IF + 120 CONTINUE +C +C Update left singular vectors if desired. +C + IF( WANTU ) + $ CALL DLASR( 'Right', 'Variable pivot', 'Forward', M, JU, + $ DWORK(JWORK), DWORK(JWORK+P-1), U, LDU ) +C + END IF +C +C Step 2: Partial diagonalization phase. +C ----------------------------- +C Diagonalize the bidiagonal Q partially until convergence +C to the desired left and/or right singular subspace. +C +C Workspace: LDW + 8*min(M,N) - 5, if WANTU or WANTV; +C Workspace: LDW + 6*min(M,N) - 3, if JOBU = JOBV = 'N'. +C + CALL MB04YD( JOBUY, JOBVY, M, N, RANK, THETA, Q, Q(PP1), U, LDU, + $ V, LDV, INUL, TOL, RELTOL, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARN, INFO ) + IF ( WANTU.OR.WANTV ) THEN + WRKOPT = MAX( WRKOPT, JWORK - 6 + 8*P ) + ELSE + WRKOPT = MAX( WRKOPT, JWORK - 4 + 6*P ) + END IF + IF ( INFO.GT.0 ) + $ RETURN +C +C Step 3: Back transformation phase. +C ------------------------- +C 3.a.: Apply the Householder transformations of the bidiagonaliza- +C tion onto the base vectors associated with the desired +C bidiagonal submatrices. +C +C Workspace: LDW + 2*min(M,N). +C + CALL MB04XY( JOBU, JOBV, MA, N, A, LDA, DWORK(ITAUQ), + $ DWORK(ITAUP), U, LDU, V, LDV, INUL, INFO ) +C +C 3.b.: If A was reduced to upper triangular form R and JOBU = 'A' +C or JOBU = 'S' apply the Householder transformations of the +C triangularization of A onto the desired base vectors. +C + IF ( QR.AND.WANTU ) THEN + IF ( ALL ) THEN +C + DO 140 I = PP1, M + INUL(I) = .TRUE. + 140 CONTINUE +C + END IF + K = IHOUSH + I = N +C + DO 160 J = 1, N - 1 + I = I - 1 + CALL DCOPY( I, DWORK(K), 1, A(J+1,J), 1 ) + K = K + I + 160 CONTINUE +C +C Workspace: MIN(M,N) + 1. +C + JWORK = PP1 + CALL MB04XY( JOBU, 'No V', M, N, A, LDA, DWORK(ITAU), + $ DWORK(ITAU), U, LDU, DWORK(JWORK), 1, INUL, INFO ) + WRKOPT = MAX( WRKOPT, PP1 ) + END IF +C +C Set the optimal workspace. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of MB04XD *** + END diff --git a/mex/sources/libslicot/MB04XY.f b/mex/sources/libslicot/MB04XY.f new file mode 100644 index 000000000..02e8e7e22 --- /dev/null +++ b/mex/sources/libslicot/MB04XY.f @@ -0,0 +1,274 @@ + SUBROUTINE MB04XY( JOBU, JOBV, M, N, X, LDX, TAUP, TAUQ, U, + $ LDU, V, LDV, INUL, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply the Householder transformations Pj stored in factored +C form into the columns of the array X, to the desired columns of +C the matrix U by premultiplication, and/or the Householder +C transformations Qj stored in factored form into the rows of the +C array X, to the desired columns of the matrix V by +C premultiplication. The Householder transformations Pj and Qj +C are stored as produced by LAPACK Library routine DGEBRD. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Specifies whether to transform the columns in U as +C follows: +C = 'N': Do not transform the columns in U; +C = 'A': Transform the columns in U (U has M columns); +C = 'S': Transform the columns in U (U has min(M,N) +C columns). +C +C JOBV CHARACTER*1 +C Specifies whether to transform the columns in V as +C follows: +C = 'N': Do not transform the columns in V; +C = 'A': Transform the columns in V (V has N columns); +C = 'S': Transform the columns in V (V has min(M,N) +C columns). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix X. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix X. N >= 0. +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading M-by-N part contains in the columns of its +C lower triangle the Householder transformations Pj, and +C in the rows of its upper triangle the Householder +C transformations Qj in factored form. +C X is modified by the routine but restored on exit. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,M). +C +C TAUP (input) DOUBLE PRECISION array, dimension (MIN(M,N)) +C The scalar factors of the Householder transformations Pj. +C +C TAUQ (input) DOUBLE PRECISION array, dimension (MIN(M,N)) +C The scalar factors of the Householder transformations Qj. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) +C On entry, U contains the M-by-M (if JOBU = 'A') or +C M-by-min(M,N) (if JOBU = 'S') matrix U. +C On exit, the Householder transformations Pj have been +C applied to each column i of U corresponding to a parameter +C INUL(i) = .TRUE. +C NOTE that U is not referenced if JOBU = 'N'. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,M), if JOBU = 'A' or JOBU = 'S'; +C LDU >= 1, if JOBU = 'N'. +C +C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) +C On entry, V contains the N-by-N (if JOBV = 'A') or +C N-by-min(M,N) (if JOBV = 'S') matrix V. +C On exit, the Householder transformations Qj have been +C applied to each column i of V corresponding to a parameter +C INUL(i) = .TRUE. +C NOTE that V is not referenced if JOBV = 'N'. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= MAX(1,M), if JOBV = 'A' or JOBV = 'S'; +C LDV >= 1, if JOBV = 'N'. +C +C INUL (input) LOGICAL array, dimension (MAX(M,N)) +C INUL(i) = .TRUE. if the i-th column of U and/or V is to be +C transformed, and INUL(i) = .FALSE., otherwise. +C (1 <= i <= MAX(M,N)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Householder transformations Pj or Qj are applied to the +C columns of U or V indexed by I for which INUL(I) = .TRUE.. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB04PZ by S. Van Huffel, Katholieke +C University Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Bidiagonalization, orthogonal transformation, singular subspace, +C singular value decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBU, JOBV + INTEGER INFO, LDU, LDV, LDX, M, N +C .. Array Arguments .. + LOGICAL INUL(*) + DOUBLE PRECISION TAUP(*), TAUQ(*), U(LDU,*), V(LDV,*), + $ X(LDX,*) +C .. Local Scalars .. + LOGICAL LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV + INTEGER I, IM, IOFF, L, NCOL, P + DOUBLE PRECISION FIRST +C .. Local Arrays .. + DOUBLE PRECISION DWORK(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARF, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MIN, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBUA = LSAME( JOBU, 'A' ) + LJOBUS = LSAME( JOBU, 'S' ) + LJOBVA = LSAME( JOBV, 'A' ) + LJOBVS = LSAME( JOBV, 'S' ) + WANTU = LJOBUA.OR.LJOBUS + WANTV = LJOBVA.OR.LJOBVS +C +C Test the input scalar arguments. +C + IF( .NOT.WANTU .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTV .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDX.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( ( WANTU.AND.LDU.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.WANTU.AND.LDU.LT.1 ) ) THEN + INFO = -10 + ELSE IF( ( WANTV.AND.LDV.LT.MAX( 1, N ) ) .OR. + $ ( .NOT.WANTV.AND.LDV.LT.1 ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'MB04XY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + P = MIN( M, N ) + IF ( P.EQ.0 ) + $ RETURN +C + IF ( M.LT.N ) THEN + IOFF = 1 + ELSE + IOFF = 0 + END IF +C +C Apply the Householder transformations Pj onto the desired +C columns of U. +C + IM = MIN( M-1, N ) + IF ( WANTU .AND. ( IM.GT.0 ) ) THEN + IF ( LJOBUA ) THEN + NCOL = M + ELSE + NCOL = P + END IF +C + DO 40 I = 1, NCOL + IF ( INUL(I) ) THEN +C + DO 20 L = IM, 1, -1 + IF ( TAUP(L).NE.ZERO ) THEN + FIRST = X(L+IOFF,L) + X(L+IOFF,L) = ONE + CALL DLARF( 'Left', M-L+1-IOFF, 1, X(L+IOFF,L), 1, + $ TAUP(L), U(L+IOFF,I), LDU, DWORK ) + X(L+IOFF,L) = FIRST + END IF + 20 CONTINUE +C + END IF + 40 CONTINUE +C + END IF +C +C Apply the Householder transformations Qj onto the desired columns +C of V. +C + IM = MIN( N-1, M ) + IF ( WANTV .AND. ( IM.GT.0 ) ) THEN + IF ( LJOBVA ) THEN + NCOL = N + ELSE + NCOL = P + END IF +C + DO 80 I = 1, NCOL + IF ( INUL(I) ) THEN +C + DO 60 L = IM, 1, -1 + IF ( TAUQ(L).NE.ZERO ) THEN + FIRST = X(L,L+1-IOFF) + X(L,L+1-IOFF) = ONE + CALL DLARF( 'Left', N-L+IOFF, 1, X(L,L+1-IOFF), + $ LDX, TAUQ(L), V(L+1-IOFF,I), LDV, + $ DWORK ) + X(L,L+1-IOFF) = FIRST + END IF + 60 CONTINUE +C + END IF + 80 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB04XY *** + END diff --git a/mex/sources/libslicot/MB04YD.f b/mex/sources/libslicot/MB04YD.f new file mode 100644 index 000000000..90ef68b27 --- /dev/null +++ b/mex/sources/libslicot/MB04YD.f @@ -0,0 +1,623 @@ + SUBROUTINE MB04YD( JOBU, JOBV, M, N, RANK, THETA, Q, E, U, LDU, V, + $ LDV, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To partially diagonalize the bidiagonal matrix +C +C |q(1) e(1) 0 ... 0 | +C | 0 q(2) e(2) . | +C J = | . . | (1) +C | . e(MIN(M,N)-1)| +C | 0 ... ... q(MIN(M,N)) | +C +C using QR or QL iterations in such a way that J is split into +C unreduced bidiagonal submatrices whose singular values are either +C all larger than a given bound or are all smaller than (or equal +C to) this bound. The left- and right-hand Givens rotations +C performed on J (corresponding to each QR or QL iteration step) may +C be optionally accumulated in the arrays U and V. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix U the left-hand Givens rotations, as follows: +C = 'N': Do not form U; +C = 'I': U is initialized to the M-by-MIN(M,N) submatrix of +C the unit matrix and the left-hand Givens rotations +C are accumulated in U; +C = 'U': The given matrix U is updated by the left-hand +C Givens rotations used in the calculation. +C +C JOBV CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix V the right-hand Givens rotations, as follows: +C = 'N': Do not form V; +C = 'I': V is initialized to the N-by-MIN(M,N) submatrix of +C the unit matrix and the right-hand Givens +C rotations are accumulated in V; +C = 'U': The given matrix V is updated by the right-hand +C Givens rotations used in the calculation. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows in matrix U. M >= 0. +C +C N (input) INTEGER +C The number of rows in matrix V. N >= 0. +C +C RANK (input/output) INTEGER +C On entry, if RANK < 0, then the rank of matrix J is +C computed by the routine as the number of singular values +C larger than THETA. +C Otherwise, RANK must specify the rank of matrix J. +C RANK <= MIN(M,N). +C On exit, if RANK < 0 on entry, then RANK contains the +C computed rank of J. That is, the number of singular +C values of J larger than THETA. +C Otherwise, the user-supplied value of RANK may be +C changed by the routine on exit if the RANK-th and the +C (RANK+1)-th singular values of J are considered to be +C equal. See also the parameter TOL. +C +C THETA (input/output) DOUBLE PRECISION +C On entry, if RANK < 0, then THETA must specify an upper +C bound on the smallest singular values of J. THETA >= 0.0. +C Otherwise, THETA must specify an initial estimate (t say) +C for computing an upper bound such that precisely RANK +C singular values are greater than this bound. +C If THETA < 0.0, then t is computed by the routine. +C On exit, if RANK >= 0 on entry, then THETA contains the +C computed upper bound such that precisely RANK singular +C values of J are greater than THETA + TOL. +C Otherwise, THETA is unchanged. +C +C Q (input/output) DOUBLE PRECISION array, dimension +C (MIN(M,N)) +C On entry, this array must contain the diagonal elements +C q(1),q(2),...,q(MIN(M,N)) of the bidiagonal matrix J. That +C is, Q(i) = J(i,i) for i = 1,2,...,MIN(M,N). +C On exit, this array contains the leading diagonal of the +C transformed bidiagonal matrix J. +C +C E (input/output) DOUBLE PRECISION array, dimension +C (MIN(M,N)-1) +C On entry, this array must contain the superdiagonal +C elements e(1),e(2),...,e(MIN(M,N)-1) of the bidiagonal +C matrix J. That is, E(k) = J(k,k+1) for k = 1,2,..., +C MIN(M,N)-1. +C On exit, this array contains the superdiagonal of the +C transformed bidiagonal matrix J. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) +C On entry, if JOBU = 'U', the leading M-by-MIN(M,N) part +C of this array must contain a left transformation matrix +C applied to the original matrix of the problem, and +C on exit, the leading M-by-MIN(M,N) part of this array +C contains the product of the input matrix U and the +C left-hand Givens rotations. +C On exit, if JOBU = 'I', then the leading M-by-MIN(M,N) +C part of this array contains the matrix of accumulated +C left-hand Givens rotations used. +C If JOBU = 'N', the array U is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDU = 1 and +C declare this array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. If JOBU = 'U' or +C JOBU = 'I', LDU >= MAX(1,M); if JOBU = 'N', LDU >= 1. +C +C V (input/output) DOUBLE PRECISION array, dimension (LDV,*) +C On entry, if JOBV = 'U', the leading N-by-MIN(M,N) part +C of this array must contain a right transformation matrix +C applied to the original matrix of the problem, and +C on exit, the leading N-by-MIN(M,N) part of this array +C contains the product of the input matrix V and the +C right-hand Givens rotations. +C On exit, if JOBV = 'I', then the leading N-by-MIN(M,N) +C part of this array contains the matrix of accumulated +C right-hand Givens rotations used. +C If JOBV = 'N', the array V is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDV = 1 and +C declare this array to be V(1,1) in the calling program). +C +C LDV INTEGER +C The leading dimension of array V. If JOBV = 'U' or +C JOBV = 'I', LDV >= MAX(1,N); if JOBV = 'N', LDV >= 1. +C +C INUL (input/output) LOGICAL array, dimension (MIN(M,N)) +C On entry, the leading MIN(M,N) elements of this array must +C be set to .FALSE. unless the i-th columns of U (if JOBU = +C 'U') and V (if JOBV = 'U') already contain a computed base +C vector of the desired singular subspace of the original +C matrix, in which case INUL(i) must be set to .TRUE. +C for 1 <= i <= MIN(M,N). +C On exit, the indices of the elements of this array with +C value .TRUE. indicate the indices of the diagonal entries +C of J which belong to those bidiagonal submatrices whose +C singular values are all less than or equal to THETA. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C This parameter defines the multiplicity of singular values +C by considering all singular values within an interval of +C length TOL as coinciding. TOL is used in checking how many +C singular values are less than or equal to THETA. Also in +C computing an appropriate upper bound THETA by a bisection +C method, TOL is used as a stopping criterion defining the +C minimum (absolute) subinterval width. TOL is also taken +C as an absolute tolerance for negligible elements in the +C QR/QL iterations. If the user sets TOL to be less than or +C equal to 0, then the tolerance is taken as +C EPS * MAX(ABS(Q(i)), ABS(E(k))), where EPS is the +C machine precision (see LAPACK Library routine DLAMCH), +C i = 1,2,...,MIN(M,N) and k = 1,2,...,MIN(M,N)-1. +C +C RELTOL DOUBLE PRECISION +C This parameter specifies the minimum relative width of an +C interval. When an interval is narrower than TOL, or than +C RELTOL times the larger (in magnitude) endpoint, then it +C is considered to be sufficiently small and bisection has +C converged. If the user sets RELTOL to be less than +C BASE * EPS, where BASE is machine radix and EPS is machine +C precision (see LAPACK Library routine DLAMCH), then the +C tolerance is taken as BASE * EPS. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,6*MIN(M,N)-5), if JOBU = 'I' or 'U', or +C JOBV = 'I' or 'U'; +C LDWORK >= MAX(1,4*MIN(M,N)-3), if JOBU = 'N' and +C JOBV = 'N'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: if the rank of the bidiagonal matrix J (as specified +C by the user) has been lowered because a singular +C value of multiplicity larger than 1 was found. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; this includes values like RANK > MIN(M,N), or +C THETA < 0.0 and RANK < 0; +C = 1: if the maximum number of QR/QL iteration steps +C (30*MIN(M,N)) has been exceeded. +C +C METHOD +C +C If the upper bound THETA is not specified by the user, then it is +C computed by the routine (using a bisection method) such that +C precisely (MIN(M,N) - RANK) singular values of J are less than or +C equal to THETA + TOL. +C +C The method used by the routine (see [1]) then proceeds as follows. +C +C The unreduced bidiagonal submatrices of J(j), where J(j) is the +C transformed bidiagonal matrix after the j-th iteration step, are +C classified into the following three classes: +C +C - C1 contains the bidiagonal submatrices with all singular values +C > THETA, +C - C2 contains the bidiagonal submatrices with all singular values +C <= THETA and +C - C3 contains the bidiagonal submatrices with singular values +C > THETA and also singular values <= THETA. +C +C If C3 is empty, then the partial diagonalization is complete, and +C RANK is the sum of the dimensions of the bidiagonal submatrices of +C C1. +C Otherwise, QR or QL iterations are performed on each bidiagonal +C submatrix of C3, until this bidiagonal submatrix has been split +C into two bidiagonal submatrices. These two submatrices are then +C classified and the iterations are restarted. +C If the upper left diagonal element of the bidiagonal submatrix is +C larger than its lower right diagonal element, then QR iterations +C are performed, else QL iterations are used. The shift is taken as +C the smallest diagonal element of the bidiagonal submatrix (in +C magnitude) unless its value exceeds THETA, in which case it is +C taken as zero. +C +C REFERENCES +C +C [1] Van Huffel, S., Vandewalle, J. and Haegemans, A. +C An efficient and reliable algorithm for computing the +C singular subspace of a matrix associated with its smallest +C singular values. +C J. Comput. and Appl. Math., 19, pp. 313-330, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C To avoid overflow, matrix J is scaled so that its largest element +C is no greater than overflow**(1/2) * underflow**(1/4) in absolute +C value (and not much smaller than that, for maximal accuracy). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routine MB04QD by S. Van Huffel, Katholieke +C University Leuven, Belgium. +C +C REVISIONS +C +C July 10, 1997. V. Sima. +C November 25, 1997. V. Sima: Setting INUL(K) = .TRUE. when handling +C 2-by-2 submatrix. +C +C KEYWORDS +C +C Bidiagonal matrix, orthogonal transformation, singular values. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN, HNDRD + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0, + $ HNDRD = 100.0D0 ) + DOUBLE PRECISION MEIGTH + PARAMETER ( MEIGTH = -0.125D0 ) + INTEGER MAXITR + PARAMETER ( MAXITR = 30 ) +C .. Scalar Arguments .. + CHARACTER JOBU, JOBV + INTEGER INFO, IWARN, LDU, LDV, LDWORK, M, N, RANK + DOUBLE PRECISION RELTOL, THETA, TOL +C .. Array Arguments .. + LOGICAL INUL(*) + DOUBLE PRECISION DWORK(*), E(*), Q(*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + LOGICAL LJOBUA, LJOBUI, LJOBVA, LJOBVI, NOC12, QRIT + INTEGER I, I1, IASCL, INFO1, ITER, J, K, MAXIT, NUMEIG, + $ OLDI, OLDK, P, R + DOUBLE PRECISION COSL, COSR, EPS, PIVMIN, RMAX, RMIN, SAFEMN, + $ SHIFT, SIGMA, SIGMN, SIGMX, SINL, SINR, SMAX, + $ SMLNUM, THETAC, THRESH, TOLABS, TOLREL, X +C .. External Functions .. + LOGICAL LSAME + INTEGER MB03ND + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME, MB03ND +C .. External Subroutines .. + EXTERNAL DLASET, DLASV2, DROT, DSCAL, MB02NY, MB03MD, + $ MB04YW, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. Executable Statements .. +C + P = MIN( M, N ) + INFO = 0 + IWARN = 0 + LJOBUI = LSAME( JOBU, 'I' ) + LJOBVI = LSAME( JOBV, 'I' ) + LJOBUA = LJOBUI.OR.LSAME( JOBU, 'U' ) + LJOBVA = LJOBVI.OR.LSAME( JOBV, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBUA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBVA .AND. .NOT.LSAME( JOBV, 'N' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( RANK.GT.P ) THEN + INFO = -5 + ELSE IF( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( .NOT.LJOBUA .AND. LDU.LT.1 .OR. + $ LJOBUA .AND. LDU.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( .NOT.LJOBVA .AND. LDV.LT.1 .OR. + $ LJOBVA .AND. LDV.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( ( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 6*P-5 ) ) + $ .OR.(.NOT.( LJOBUA.OR.LJOBVA ) .AND. LDWORK.LT.MAX( 1, 4*P-3 ) ) + $ ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB04YD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( P.EQ.0 ) THEN + IF ( RANK.GE.0 ) + $ THETA = ZERO + RANK = 0 + RETURN + END IF +C +C Set tolerances and machine parameters. +C + TOLABS = TOL + TOLREL = RELTOL + SMAX = ABS( Q(P) ) +C + DO 20 J = 1, P - 1 + SMAX = MAX( SMAX, ABS( Q(J) ), ABS( E(J) ) ) + 20 CONTINUE +C + SAFEMN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Epsilon' ) + IF ( TOLABS.LE.ZERO ) TOLABS = EPS*SMAX + X = DLAMCH( 'Base' )*EPS + IF ( TOLREL.LE.X ) TOLREL = X + THRESH = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )*EPS + SMLNUM = SAFEMN / EPS + RMIN = SQRT( SMLNUM ) + RMAX = MIN( ONE / RMIN, ONE / SQRT( SQRT( SAFEMN ) ) ) + THETAC = THETA +C +C Scale the matrix to allowable range, if necessary, and set PIVMIN, +C using the squares of Q and E (saved in DWORK). +C + IASCL = 0 + IF( SMAX.GT.ZERO .AND. SMAX.LT.RMIN ) THEN + IASCL = 1 + SIGMA = RMIN / SMAX + ELSE IF( SMAX.GT.RMAX ) THEN + IASCL = 1 + SIGMA = RMAX / SMAX + END IF + IF( IASCL.EQ.1 ) THEN + CALL DSCAL( P, SIGMA, Q, 1 ) + CALL DSCAL( P-1, SIGMA, E, 1 ) + THETAC = SIGMA*THETA + TOLABS = SIGMA*TOLABS + END IF +C + PIVMIN = Q(P)**2 + DWORK(P) = PIVMIN +C + DO 40 J = 1, P - 1 + DWORK(J) = Q(J)**2 + DWORK(P+J) = E(J)**2 + PIVMIN = MAX( PIVMIN, DWORK(J), DWORK(P+J) ) + 40 CONTINUE +C + PIVMIN = MAX( PIVMIN*SAFEMN, SAFEMN ) +C +C Initialize U and/or V to the identity matrix, if needed. +C + IF ( LJOBUI ) + $ CALL DLASET( 'Full', M, P, ZERO, ONE, U, LDU ) + IF ( LJOBVI ) + $ CALL DLASET( 'Full', N, P, ZERO, ONE, V, LDV ) +C +C Estimate THETA (if not fixed by the user), and set R. +C + IF ( RANK.GE.0 ) THEN + J = P - RANK + CALL MB03MD( P, J, THETAC, Q, E, DWORK(1), DWORK(P+1), PIVMIN, + $ TOLABS, TOLREL, IWARN, INFO1 ) + THETA = THETAC + IF ( IASCL.EQ.1 ) THETA = THETA / SIGMA + IF ( J.LE.0 ) + $ RETURN + R = P - J + ELSE + R = P - MB03ND( P, THETAC, DWORK, DWORK(P+1), PIVMIN, INFO1 ) + END IF +C + RANK = P +C + DO 60 I = 1, P + IF ( INUL(I) ) RANK = RANK - 1 + 60 CONTINUE +C +C From now on K is the smallest known index such that the elements +C of the bidiagonal matrix J with indices larger than K belong to C1 +C or C2. +C RANK = P - SUM(dimensions of known bidiagonal matrices of C2). +C + K = P + OLDI = -1 + OLDK = -1 + ITER = 0 + MAXIT = MAXITR*P +C WHILE ( C3 NOT EMPTY ) DO + 80 IF ( RANK.GT.R .AND. K.GT.0 ) THEN +C WHILE ( K.GT.0 .AND. INUL(K) ) DO +C +C Search for the rightmost index of a bidiagonal submatrix, +C not yet classified. +C + 100 IF ( K.GT.0 ) THEN + IF ( INUL(K) ) THEN + K = K - 1 + GO TO 100 + END IF + END IF +C END WHILE 100 +C + IF ( K.EQ.0 ) + $ RETURN +C + NOC12 = .TRUE. +C WHILE ((ITER < MAXIT).AND.(No bidiagonal matrix of C1 or +C C2 found)) DO + 120 IF ( ( ITER.LT.MAXIT ) .AND. NOC12 ) THEN +C +C Search for negligible Q(I) or E(I-1) (for I > 1) and find +C the shift. +C + I = K + X = ABS( Q(I) ) + SHIFT = X +C WHILE ABS( Q(I) ) > TOLABS .AND. ABS( E(I-1) ) > TOLABS ) DO + 140 IF ( I.GT.1 ) THEN + IF ( ( X.GT.TOLABS ).AND.( ABS( E(I-1) ).GT.TOLABS ) ) + $ THEN + I = I - 1 + X = ABS( Q(I) ) + IF ( X.LT.SHIFT ) SHIFT = X + GO TO 140 + END IF + END IF +C END WHILE 140 +C +C Classify the bidiagonal submatrix (of order J) found. +C + J = K - I + 1 + IF ( ( X.LE.TOLABS ) .OR. ( K.EQ.I ) ) THEN + NOC12 = .FALSE. + ELSE + NUMEIG = MB03ND( J, THETAC, DWORK(I), DWORK(P+I), PIVMIN, + $ INFO1 ) + IF ( NUMEIG.GE.J .OR. NUMEIG.LE.0 ) NOC12 = .FALSE. + END IF + IF ( NOC12 ) THEN + IF ( J.EQ.2 ) THEN +C +C Handle separately the 2-by-2 submatrix. +C + CALL DLASV2( Q(I), E(I), Q(K), SIGMN, SIGMX, SINR, + $ COSR, SINL, COSL ) + Q(I) = SIGMX + Q(K) = SIGMN + E(I) = ZERO + RANK = RANK - 1 + INUL(K) = .TRUE. + NOC12 = .FALSE. +C +C Update U and/or V, if needed. +C + IF( LJOBUA ) + $ CALL DROT( M, U(1,I), 1, U(1,K), 1, COSL, SINL ) + IF( LJOBVA ) + $ CALL DROT( N, V(1,I), 1, V(1,K), 1, COSR, SINR ) + ELSE +C +C If working on new submatrix, choose QR or +C QL iteration. +C + IF ( I.NE.OLDI .OR. K.NE.OLDK ) + $ QRIT = ABS( Q(I) ).GE.ABS( Q(K) ) + OLDI = I + IF ( QRIT ) THEN + IF ( ABS( E(K-1) ).LE.THRESH*ABS( Q(K) ) ) + $ E(K-1) = ZERO + ELSE + IF ( ABS( E(I) ).LE.THRESH*ABS( Q(I) ) ) + $ E(I) = ZERO + END IF +C + CALL MB04YW( QRIT, LJOBUA, LJOBVA, M, N, I, K, SHIFT, + $ Q, E, U, LDU, V, LDV, DWORK(2*P) ) +C + IF ( QRIT ) THEN + IF ( ABS( E(K-1) ).LE.TOLABS ) E(K-1) = ZERO + ELSE + IF ( ABS( E(I) ).LE.TOLABS ) E(I) = ZERO + END IF + DWORK(K) = Q(K)**2 +C + DO 160 I1 = I, K - 1 + DWORK(I1) = Q(I1)**2 + DWORK(P+I1) = E(I1)**2 + 160 CONTINUE +C + ITER = ITER + 1 + END IF + END IF + GO TO 120 + END IF +C END WHILE 120 +C + IF ( ITER.GE.MAXIT ) THEN + INFO = 1 + GO TO 200 + END IF +C + IF ( X.LE.TOLABS ) THEN +C +C Split at negligible diagonal element ABS( Q(I) ) <= TOLABS. +C + CALL MB02NY( LJOBUA, LJOBVA, M, N, I, K, Q, E, U, LDU, V, + $ LDV, DWORK(2*P) ) + INUL(I) = .TRUE. + RANK = RANK - 1 + ELSE +C +C A negligible superdiagonal element ABS( E(I-1) ) <= TOL +C has been found, the corresponding bidiagonal submatrix +C belongs to C1 or C2. Treat this bidiagonal submatrix. +C + IF ( J.GE.2 ) THEN + IF ( NUMEIG.EQ.J ) THEN +C + DO 180 I1 = I, K + INUL(I1) = .TRUE. + 180 CONTINUE +C + RANK = RANK - J + K = K - J + ELSE + K = I - 1 + END IF + ELSE + IF ( X.LE.( THETAC + TOLABS ) ) THEN + INUL(I) = .TRUE. + RANK = RANK - 1 + END IF + K = K - 1 + END IF + OLDK = K + END IF + GO TO 80 + END IF +C END WHILE 80 +C +C If matrix was scaled, then rescale Q and E appropriately. +C + 200 CONTINUE + IF( IASCL.EQ.1 ) THEN + CALL DSCAL( P, ONE / SIGMA, Q, 1 ) + CALL DSCAL( P-1, ONE / SIGMA, E, 1 ) + END IF +C + RETURN +C *** Last line of MB04YD *** + END diff --git a/mex/sources/libslicot/MB04YW.f b/mex/sources/libslicot/MB04YW.f new file mode 100644 index 000000000..0090d5111 --- /dev/null +++ b/mex/sources/libslicot/MB04YW.f @@ -0,0 +1,513 @@ + SUBROUTINE MB04YW( QRIT, UPDATU, UPDATV, M, N, L, K, SHIFT, D, E, + $ U, LDU, V, LDV, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform either one QR or QL iteration step onto the unreduced +C bidiagonal submatrix Jk: +C +C |D(l) E(l) 0 ... 0 | +C | 0 D(l+1) E(l+1) . | +C Jk = | . . | +C | . . | +C | . E(k-1)| +C | 0 ... ... D(k) | +C +C with k <= p and l >= 1, p = MIN(M,N), of the bidiagonal matrix J: +C +C |D(1) E(1) 0 ... 0 | +C | 0 D(2) E(2) . | +C J = | . . |. +C | . . | +C | . E(p-1)| +C | 0 ... ... D(p) | +C +C Hereby, Jk is transformed to S' Jk T with S and T products of +C Givens rotations. These Givens rotations S (respectively, T) are +C postmultiplied into U (respectively, V), if UPDATU (respectively, +C UPDATV) is .TRUE.. +C +C ARGUMENTS +C +C Mode Parameters +C +C QRIT LOGICAL +C Indicates whether a QR or QL iteration step is to be +C taken (from larger end diagonal element towards smaller), +C as follows: +C = .TRUE. : QR iteration step (chase bulge from top to +C bottom); +C = .FALSE.: QL iteration step (chase bulge from bottom to +C top). +C +C UPDATU LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix U the left-hand Givens rotations S, as follows: +C = .FALSE.: Do not form U; +C = .TRUE. : The given matrix U is updated (postmultiplied) +C by the left-hand Givens rotations S. +C +C UPDATV LOGICAL +C Indicates whether the user wishes to accumulate in a +C matrix V the right-hand Givens rotations S, as follows: +C = .FALSE.: Do not form V; +C = .TRUE. : The given matrix V is updated (postmultiplied) +C by the right-hand Givens rotations T. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix U. M >= 0. +C +C N (input) INTEGER +C The number of rows of the matrix V. N >= 0. +C +C L (input) INTEGER +C The index of the first diagonal entry of the considered +C unreduced bidiagonal submatrix Jk of J. +C +C K (input) INTEGER +C The index of the last diagonal entry of the considered +C unreduced bidiagonal submatrix Jk of J. +C +C SHIFT (input) DOUBLE PRECISION +C Value of the shift used in the QR or QL iteration step. +C +C D (input/output) DOUBLE PRECISION array, dimension (p) +C where p = MIN(M,N) +C On entry, D must contain the diagonal entries of the +C bidiagonal matrix J. +C On exit, D contains the diagonal entries of the +C transformed bidiagonal matrix S' J T. +C +C E (input/output) DOUBLE PRECISION array, dimension (p-1) +C On entry, E must contain the superdiagonal entries of J. +C On exit, E contains the superdiagonal entries of the +C transformed matrix S' J T. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,p) +C On entry, if UPDATU = .TRUE., U must contain the M-by-p +C left transformation matrix. +C On exit, if UPDATU = .TRUE., the Givens rotations S on the +C left have been postmultiplied into U, i.e., U * S is +C returned. +C U is not referenced if UPDATU = .FALSE.. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= max(1,M) if UPDATU = .TRUE.; +C LDU >= 1 if UPDATU = .FALSE.. +C +C V (input/output) DOUBLE PRECISION array, dimension (LDV,p) +C On entry, if UPDATV = .TRUE., V must contain the N-by-p +C right transformation matrix. +C On exit, if UPDATV = .TRUE., the Givens rotations T on the +C right have been postmultiplied into V, i.e., V * T is +C returned. +C V is not referenced if UPDATV = .FALSE.. +C +C LDV INTEGER +C The leading dimension of the array V. +C LDV >= max(1,N) if UPDATV = .TRUE.; +C LDV >= 1 if UPDATV = .FALSE.. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(1,LDWORK)) +C LDWORK >= 4*MIN(M,N)-4, if UPDATU = UPDATV = .TRUE.; +C LDWORK >= 2*MIN(M,N)-2, if +C UPDATU = .TRUE. and UPDATV = .FALSE. or +C UPDATV = .TRUE. and UPDATU = .FALSE.; +C LDWORK >= 1, if UPDATU = UPDATV = .FALSE.. +C +C METHOD +C +C QR iterations diagonalize the bidiagonal matrix by zeroing the +C super-diagonal elements of Jk from bottom to top. +C QL iterations diagonalize the bidiagonal matrix by zeroing the +C super-diagonal elements of Jk from top to bottom. +C The routine overwrites Jk with the bidiagonal matrix S' Jk T, +C where S and T are products of Givens rotations. +C T is essentially the orthogonal matrix that would be obtained by +C applying one implicit symmetric shift QR (QL) step onto the matrix +C Jk'Jk. This step factors the matrix (Jk'Jk - shift*I) into a +C product of an orthogonal matrix T and a upper (lower) triangular +C matrix. See [1,Sec.8.2-8.3] and [2] for more details. +C +C REFERENCES +C +C [1] Golub, G.H. and Van Loan, C.F. +C Matrix Computations. +C The Johns Hopkins University Press, Baltimore, Maryland, 1983. +C +C [2] Bowdler, H., Martin, R.S. and Wilkinson, J.H. +C The QR and QL algorithms for symmetric matrices. +C Numer. Math., 11, pp. 293-306, 1968. +C +C [3] Demmel, J. and Kahan, W. +C Computing small singular values of bidiagonal matrices with +C guaranteed high relative accuracy. +C SIAM J. Sci. Statist. Comput., 11, pp. 873-912, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997. +C Supersedes Release 2.0 routines MB04QY and MB04QZ by S. Van +C Huffel, Katholieke University Leuven, Belgium. +C This subroutine is based on the QR/QL step implemented in LAPACK +C routine DBDSQR. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Bidiagonal matrix, orthogonal transformation, singular values. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL QRIT, UPDATU, UPDATV + INTEGER K, L, LDU, LDV, M, N + DOUBLE PRECISION SHIFT +C .. +C .. Array Arguments .. + DOUBLE PRECISION D( * ), DWORK( * ), E( * ), U( LDU, * ), + $ V( LDV, * ) +C .. +C .. Local Scalars .. + INTEGER I, IROT, NCV, NM1, NM12, NM13 + DOUBLE PRECISION COSL, COSR, CS, F, G, H, OLDCS, OLDSN, R, SINL, + $ SINR, SN +C .. +C .. External Subroutines .. + EXTERNAL DLARTG, DLASR +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN, SIGN +C .. +C .. Executable Statements .. +C +C For speed, no tests of the input scalar arguments are done. +C +C Quick return if possible. +C + NCV = MIN( M, N ) + IF ( NCV.LE.1 .OR. L.EQ.K ) + $ RETURN +C + NM1 = NCV - 1 + NM12 = NM1 + NM1 + NM13 = NM12 + NM1 + IF ( .NOT.UPDATV ) THEN + NM12 = 0 + NM13 = NM1 + END IF +C +C If SHIFT = 0, do simplified QR iteration. +C + IF( SHIFT.EQ.ZERO ) THEN + IF( QRIT ) THEN +C +C Chase bulge from top to bottom. +C Save cosines and sines for later U and/or V updates, +C if needed. +C + CS = ONE + OLDCS = ONE + CALL DLARTG( D( L )*CS, E( L ), CS, SN, R ) + CALL DLARTG( OLDCS*R, D( L+1 )*SN, OLDCS, OLDSN, D( L ) ) + IF ( UPDATV ) THEN + DWORK( 1 ) = CS + DWORK( 1+NM1 ) = SN + END IF + IF ( UPDATU ) THEN + DWORK( 1+NM12 ) = OLDCS + DWORK( 1+NM13 ) = OLDSN + END IF + IROT = 1 +C + DO 110 I = L + 1, K - 1 + CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) + E( I-1 ) = OLDSN*R + CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) + IROT = IROT + 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = CS + DWORK( IROT+NM1 ) = SN + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = OLDCS + DWORK( IROT+NM13 ) = OLDSN + END IF + 110 CONTINUE +C + H = D( K )*CS + D( K ) = H*OLDCS + E( K-1 ) = H*OLDSN +C +C Update U and/or V. +C + IF( UPDATV ) + $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), + $ DWORK( NCV ), V( 1, L ), LDV ) + IF( UPDATU ) + $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), + $ DWORK( NM13+1 ), U( 1, L ), LDU ) +C + ELSE +C +C Chase bulge from bottom to top. +C Save cosines and sines for later U and/or V updates, +C if needed. +C + CS = ONE + OLDCS = ONE + CALL DLARTG( D( K )*CS, E( K-1 ), CS, SN, R ) + CALL DLARTG( OLDCS*R, D( K-1 )*SN, OLDCS, OLDSN, D( K ) ) + IF ( UPDATV ) THEN + DWORK( K-L ) = OLDCS + DWORK( K-L+NM1 ) = -OLDSN + END IF + IF ( UPDATU ) THEN + DWORK( K-L+NM12 ) = CS + DWORK( K-L+NM13 ) = -SN + END IF + IROT = K - L +C + DO 120 I = K - 1, L + 1, -1 + CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) + E( I ) = OLDSN*R + CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) + IROT = IROT - 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = OLDCS + DWORK( IROT+NM1 ) = -OLDSN + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = CS + DWORK( IROT+NM13 ) = -SN + END IF + 120 CONTINUE +C + H = D( L )*CS + D( L ) = H*OLDCS + E( L ) = H*OLDSN +C +C Update U and/or V. +C + IF( UPDATV ) + $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), + $ DWORK( NCV ), V( 1, L ), LDV ) + IF( UPDATU ) + $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), + $ DWORK( NM13+1 ), U( 1, L ), LDU ) + END IF + ELSE +C +C Use nonzero shift. +C + IF( QRIT ) THEN +C +C Chase bulge from top to bottom. +C Save cosines and sines for later U and/or V updates, +C if needed. +C + F = ( ABS( D( L ) ) - SHIFT )* + $ ( SIGN( ONE, D( L ) ) + SHIFT / D( L ) ) + G = E( L ) + CALL DLARTG( F, G, COSR, SINR, R ) + F = COSR*D( L ) + SINR*E( L ) + E( L ) = COSR*E( L ) - SINR*D( L ) + G = SINR*D( L+1 ) + D( L+1 ) = COSR*D( L+1 ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( L ) = R + F = COSL*E( L ) + SINL*D( L+1 ) + D( L+1 ) = COSL*D( L+1 ) - SINL*E( L ) + G = SINL*E( L+1 ) + E( L+1 ) = COSL*E( L+1 ) + IF ( UPDATV ) THEN + DWORK( 1 ) = COSR + DWORK( 1+NM1 ) = SINR + END IF + IF ( UPDATU ) THEN + DWORK( 1+NM12 ) = COSL + DWORK( 1+NM13 ) = SINL + END IF + IROT = 1 +C + DO 130 I = L + 1, K - 2 + CALL DLARTG( F, G, COSR, SINR, R ) + E( I-1 ) = R + F = COSR*D( I ) + SINR*E( I ) + E( I ) = COSR*E( I ) - SINR*D( I ) + G = SINR*D( I+1 ) + D( I+1 ) = COSR*D( I+1 ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( I ) = R + F = COSL*E( I ) + SINL*D( I+1 ) + D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) + G = SINL*E( I+1 ) + E( I+1 ) = COSL*E( I+1 ) + IROT = IROT + 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = COSR + DWORK( IROT+NM1 ) = SINR + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = COSL + DWORK( IROT+NM13 ) = SINL + END IF + 130 CONTINUE +C + IF ( L.LT.K-1 ) THEN + CALL DLARTG( F, G, COSR, SINR, R ) + E( K-2 ) = R + F = COSR*D( K-1 ) + SINR*E( K-1 ) + E( K-1 ) = COSR*E( K-1 ) - SINR*D( K-1 ) + G = SINR*D( K ) + D( K ) = COSR*D( K ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( K-1 ) = R + F = COSL*E( K-1 ) + SINL*D( K ) + D( K ) = COSL*D( K ) - SINL*E( K-1 ) + IROT = IROT + 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = COSR + DWORK( IROT+NM1 ) = SINR + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = COSL + DWORK( IROT+NM13 ) = SINL + END IF + END IF + E( K-1 ) = F +C +C Update U and/or V. +C + IF( UPDATV ) + $ CALL DLASR( 'R', 'V', 'F', N, K-L+1, DWORK( 1 ), + $ DWORK( NCV ), V( 1, L ), LDV ) + IF( UPDATU ) + $ CALL DLASR( 'R', 'V', 'F', M, K-L+1, DWORK( NM12+1 ), + $ DWORK( NM13+1 ), U( 1, L ), LDU ) +C + ELSE +C +C Chase bulge from bottom to top. +C Save cosines and sines for later U and/or V updates, +C if needed. +C + F = ( ABS( D( K ) ) - SHIFT )* + $ ( SIGN( ONE, D( K ) ) + SHIFT / D( K ) ) + G = E( K-1 ) + IF ( L.LT.K-1 ) THEN + CALL DLARTG( F, G, COSR, SINR, R ) + F = COSR*D( K ) + SINR*E( K-1 ) + E( K-1 ) = COSR*E( K-1 ) - SINR*D( K ) + G = SINR*D( K-1 ) + D( K-1 ) = COSR*D( K-1 ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( K ) = R + F = COSL*E( K-1 ) + SINL*D( K-1 ) + D( K-1 ) = COSL*D( K-1 ) - SINL*E( K-1 ) + G = SINL*E( K-2 ) + E( K-2 ) = COSL*E( K-2 ) + IF ( UPDATV ) THEN + DWORK( K-L ) = COSL + DWORK( K-L+NM1 ) = -SINL + END IF + IF ( UPDATU ) THEN + DWORK( K-L+NM12 ) = COSR + DWORK( K-L+NM13 ) = -SINR + END IF + IROT = K - L + ELSE + IROT = K - L + 1 + END IF +C + DO 140 I = K - 1, L + 2, -1 + CALL DLARTG( F, G, COSR, SINR, R ) + E( I ) = R + F = COSR*D( I ) + SINR*E( I-1 ) + E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) + G = SINR*D( I-1 ) + D( I-1 ) = COSR*D( I-1 ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( I ) = R + F = COSL*E( I-1 ) + SINL*D( I-1 ) + D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) + G = SINL*E( I-2 ) + E( I-2 ) = COSL*E( I-2 ) + IROT = IROT - 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = COSL + DWORK( IROT+NM1 ) = -SINL + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = COSR + DWORK( IROT+NM13 ) = -SINR + END IF + 140 CONTINUE +C + CALL DLARTG( F, G, COSR, SINR, R ) + E( L+1 ) = R + F = COSR*D( L+1 ) + SINR*E( L ) + E( L ) = COSR*E( L ) - SINR*D( L+1 ) + G = SINR*D( L ) + D( L ) = COSR*D( L ) + CALL DLARTG( F, G, COSL, SINL, R ) + D( L+1 ) = R + F = COSL*E( L ) + SINL*D( L ) + D( L ) = COSL*D( L ) - SINL*E( L ) + IROT = IROT - 1 + IF ( UPDATV ) THEN + DWORK( IROT ) = COSL + DWORK( IROT+NM1 ) = -SINL + END IF + IF ( UPDATU ) THEN + DWORK( IROT+NM12 ) = COSR + DWORK( IROT+NM13 ) = -SINR + END IF + E( L ) = F +C +C Update U and/or V if desired. +C + IF( UPDATV ) + $ CALL DLASR( 'R', 'V', 'B', N, K-L+1, DWORK( 1 ), + $ DWORK( NCV ), V( 1, L ), LDV ) + IF( UPDATU ) + $ CALL DLASR( 'R', 'V', 'B', M, K-L+1, DWORK( NM12+1 ), + $ DWORK( NM13+1 ), U( 1, L ), LDU ) + END IF + END IF +C + RETURN +C *** Last line of MB04YW *** + END diff --git a/mex/sources/libslicot/MB04ZD.f b/mex/sources/libslicot/MB04ZD.f new file mode 100644 index 000000000..63c77e6a1 --- /dev/null +++ b/mex/sources/libslicot/MB04ZD.f @@ -0,0 +1,486 @@ + SUBROUTINE MB04ZD( COMPU, N, A, LDA, QG, LDQG, U, LDU, DWORK, INFO + $ ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To transform a Hamiltonian matrix +C +C ( A G ) +C H = ( T ) (1) +C ( Q -A ) +C +C into a square-reduced Hamiltonian matrix +C +C ( A' G' ) +C H' = ( T ) (2) +C ( Q' -A' ) +C T +C by an orthogonal symplectic similarity transformation H' = U H U, +C where +C ( U1 U2 ) +C U = ( ). (3) +C ( -U2 U1 ) +C T +C The square-reduced Hamiltonian matrix satisfies Q'A' - A' Q' = 0, +C and +C +C 2 T 2 ( A'' G'' ) +C H' := (U H U) = ( T ). +C ( 0 A'' ) +C +C In addition, A'' is upper Hessenberg and G'' is skew symmetric. +C The square roots of the eigenvalues of A'' = A'*A' + G'*Q' are the +C eigenvalues of H. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPU CHARACTER*1 +C Indicates whether the orthogonal symplectic similarity +C transformation matrix U in (3) is returned or +C accumulated into an orthogonal symplectic matrix, or if +C the transformation matrix is not required, as follows: +C = 'N': U is not required; +C = 'I' or 'F': on entry, U need not be set; +C on exit, U contains the orthogonal +C symplectic matrix U from (3); +C = 'V' or 'A': the orthogonal symplectic similarity +C transformations are accumulated into U; +C on input, U must contain an orthogonal +C symplectic matrix S; +C on exit, U contains S*U with U from (3). +C See the description of U below for details. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On input, the leading N-by-N part of this array must +C contain the upper left block A of the Hamiltonian matrix H +C in (1). +C On output, the leading N-by-N part of this array contains +C the upper left block A' of the square-reduced Hamiltonian +C matrix H' in (2). +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C QG (input/output) DOUBLE PRECISION array, dimension +C (LDQG,N+1) +C On input, the leading N-by-N lower triangular part of this +C array must contain the lower triangle of the lower left +C symmetric block Q of the Hamiltonian matrix H in (1), and +C the N-by-N upper triangular part of the submatrix in the +C columns 2 to N+1 of this array must contain the upper +C triangle of the upper right symmetric block G of H in (1). +C So, if i >= j, then Q(i,j) = Q(j,i) is stored in QG(i,j) +C and G(i,j) = G(j,i) is stored in QG(j,i+1). +C On output, the leading N-by-N lower triangular part of +C this array contains the lower triangle of the lower left +C symmetric block Q', and the N-by-N upper triangular part +C of the submatrix in the columns 2 to N+1 of this array +C contains the upper triangle of the upper right symmetric +C block G' of the square-reduced Hamiltonian matrix H' +C in (2). +C +C LDQG INTEGER +C The leading dimension of the array QG. LDQG >= MAX(1,N). +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,2*N) +C If COMPU = 'N', then this array is not referenced. +C If COMPU = 'I' or 'F', then the input contents of this +C array are not specified. On output, the leading +C N-by-(2*N) part of this array contains the first N rows +C of the orthogonal symplectic matrix U in (3). +C If COMPU = 'V' or 'A', then, on input, the leading +C N-by-(2*N) part of this array must contain the first N +C rows of an orthogonal symplectic matrix S. On output, the +C leading N-by-(2*N) part of this array contains the first N +C rows of the product S*U where U is the orthogonal +C symplectic matrix from (3). +C The storage scheme implied by (3) is used for orthogonal +C symplectic matrices, i.e., only the first N rows are +C stored, as they contain all relevant information. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= MAX(1,N), if COMPU <> 'N'; +C LDU >= 1, if COMPU = 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, then the i-th argument had an illegal +C value. +C +C METHOD +C +C The Hamiltonian matrix H is transformed into a square-reduced +C Hamiltonian matrix H' using the implicit version of Van Loan's +C method as proposed in [1,2,3]. +C +C REFERENCES +C +C [1] Van Loan, C. F. +C A Symplectic Method for Approximating All the Eigenvalues of +C a Hamiltonian Matrix. +C Linear Algebra and its Applications, 61, pp. 233-251, 1984. +C +C [2] Byers, R. +C Hamiltonian and Symplectic Algorithms for the Algebraic +C Riccati Equation. +C Ph. D. Thesis, Cornell University, Ithaca, NY, January 1983. +C +C [3] Benner, P., Byers, R., and Barth, E. +C Fortran 77 Subroutines for Computing the Eigenvalues of +C Hamiltonian Matrices. I: The Square-Reduced Method. +C ACM Trans. Math. Software, 26, 1, pp. 49-77, 2000. +C +C NUMERICAL ASPECTS +C +C This algorithm requires approximately 20*N**3 flops for +C transforming H into square-reduced form. If the transformations +C are required, this adds another 8*N**3 flops. The method is +C strongly backward stable in the sense that if H' and U are the +C computed square-reduced Hamiltonian and computed orthogonal +C symplectic similarity transformation, then there is an orthogonal +C symplectic matrix T and a Hamiltonian matrix M such that +C +C H T = T M +C +C || T - U || <= c1 * eps +C +C || H' - M || <= c2 * eps * || H || +C +C where c1, c2 are modest constants depending on the dimension N and +C eps is the machine precision. +C +C Eigenvalues computed by explicitly forming the upper Hessenberg +C matrix A'' = A'A' + G'Q', with A', G', and Q' as in (2), and +C applying the Hessenberg QR iteration to A'' are exactly +C eigenvalues of a perturbed Hamiltonian matrix H + E, where +C +C || E || <= c3 * sqrt(eps) * || H ||, +C +C and c3 is a modest constant depending on the dimension N and eps +C is the machine precision. Moreover, if the norm of H and an +C eigenvalue lambda are of roughly the same magnitude, the computed +C eigenvalue is essentially as accurate as the computed eigenvalue +C from traditional methods. See [1] or [2]. +C +C CONTRIBUTOR +C +C P. Benner, Universitaet Bremen, Germany, +C R. Byers, University of Kansas, Lawrence, USA, and +C E. Barth, Kalamazoo College, Kalamazoo, USA, +C Aug. 1998, routine DHASRD. +C V. Sima, Research Institute for Informatics, Bucharest, Romania, +C Oct. 1998, SLICOT Library version. +C +C REVISIONS +C +C May 2001, A. Varga, German Aeropsce Center, DLR Oberpfaffenhofen. +C May 2009, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Orthogonal transformation, (square-reduced) Hamiltonian matrix, +C symplectic similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. +C + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDQG, LDU, N + CHARACTER COMPU +C .. +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), DWORK(*), QG(LDQG,*), U(LDU,*) +C .. +C .. Local Scalars .. + DOUBLE PRECISION COSINE, SINE, TAU, TEMP, X, Y + INTEGER J + LOGICAL ACCUM, FORGET, FORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1), T(2,2) +C .. +C .. External Functions .. + DOUBLE PRECISION DDOT + LOGICAL LSAME + EXTERNAL DDOT, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DLARFX, DLARTG, + $ DROT, DSYMV, DSYR2, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C + INFO = 0 + ACCUM = LSAME( COMPU, 'A' ) .OR. LSAME( COMPU, 'V' ) + FORM = LSAME( COMPU, 'F' ) .OR. LSAME( COMPU, 'I' ) + FORGET = LSAME( COMPU, 'N' ) +C + IF ( .NOT.ACCUM .AND. .NOT.FORM .AND. .NOT.FORGET ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDQG.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.1 .OR. ( .NOT.FORGET .AND. LDU.LT.MAX( 1, N ) ) ) + $ THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'MB04ZD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Transform to square-reduced form. +C + DO 10 J = 1, N - 1 +C T +C DWORK <- (Q*A - A *Q)(J+1:N,J). +C + CALL DCOPY( J-1, QG(J,1), LDQG, DWORK(N+1), 1 ) + CALL DCOPY( N-J+1, QG(J,J), 1, DWORK(N+J), 1 ) + CALL DGEMV( 'Transpose', N, N-J, -ONE, A(1,J+1), LDA, + $ DWORK(N+1), 1, ZERO, DWORK(J+1), 1 ) + CALL DGEMV( 'NoTranspose', N-J, J, ONE, QG(J+1,1), LDQG, + $ A(1,J), 1, ONE, DWORK(J+1), 1 ) + CALL DSYMV( 'Lower', N-J, ONE, QG(J+1,J+1), LDQG, A(J+1,J), 1, + $ ONE, DWORK(J+1), 1 ) +C +C Symplectic reflection to zero (H*H)((N+J+2):2N,J). +C + CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) + Y = DWORK(J+1) + DWORK(J+1) = ONE +C + CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, + $ DWORK(N+1) ) + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, + $ DWORK(N+1) ) +C + CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, + $ DWORK(N+1) ) + CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), + $ 1, ZERO, DWORK(N+J+1), 1 ) + CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), + $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) + CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, + $ QG(J+1,J+1), LDQG ) +C + CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, + $ DWORK(N+1) ) + CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), + $ 1, ZERO, DWORK(N+J+1), 1 ) + CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), + $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) + CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, + $ QG(J+1,J+2), LDQG ) +C + IF ( FORM ) THEN +C +C Save reflection. +C + CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,J), 1 ) + U(J+1,J) = TAU +C + ELSE IF ( ACCUM ) THEN +C +C Accumulate reflection. +C + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), + $ LDU, DWORK(N+1) ) + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), + $ LDU, DWORK(N+1) ) + END IF +C +C (X,Y) := ((J+1,J),(N+J+1,J)) component of H*H. +C + X = DDOT( J, QG(1,J+2), 1, QG(J,1), LDQG ) + + $ DDOT( N-J, QG(J+1,J+2), LDQG, QG(J+1,J), 1 ) + + $ DDOT( N, A(J+1,1), LDA, A(1,J), 1 ) +C +C Symplectic rotation to zero (H*H)(N+J+1,J). +C + CALL DLARTG( X, Y, COSINE, SINE, TEMP ) +C + CALL DROT( J, A(J+1,1), LDA, QG(J+1,1), LDQG, COSINE, SINE ) + CALL DROT( J, A(1,J+1), 1, QG(1,J+2), 1, COSINE, SINE ) + IF( J.LT.N-1 ) THEN + CALL DROT( N-J-1, A(J+1,J+2), LDA, QG(J+2,J+1), 1, + $ COSINE, SINE ) + CALL DROT( N-J-1, A(J+2,J+1), 1, QG(J+1,J+3), LDQG, + $ COSINE, SINE ) + END IF +C + T(1,1) = A(J+1,J+1) + T(1,2) = QG(J+1,J+2) + T(2,1) = QG(J+1,J+1) + T(2,2) = -T(1,1) + CALL DROT( 2, T(1,1), 1, T(1,2), 1, COSINE, SINE ) + CALL DROT( 2, T(1,1), 2, T(2,1), 2, COSINE, SINE ) + A(J+1,J+1) = T(1,1) + QG(J+1,J+2) = T(1,2) + QG(J+1,J+1) = T(2,1) +C + IF ( FORM ) THEN +C +C Save rotation. +C + U(J,J) = COSINE + U(J,N+J) = SINE +C + ELSE IF ( ACCUM ) THEN +C +C Accumulate rotation. +C + CALL DROT( N, U(1,J+1), 1, U(1,N+J+1), 1, COSINE, SINE ) + END IF +C +C DWORK := (A*A + G*Q)(J+1:N,J). +C + CALL DGEMV( 'NoTranspose', N-J, N, ONE, A(J+1,1), LDA, A(1,J), + $ 1, ZERO, DWORK(J+1), 1 ) + CALL DGEMV( 'Transpose', J, N-J, ONE, QG(1,J+2), LDQG, QG(J,1), + $ LDQG, ONE, DWORK(J+1), 1 ) + CALL DSYMV( 'Upper', N-J, ONE, QG(J+1,J+2), LDQG, QG(J+1,J), 1, + $ ONE, DWORK(J+1), 1 ) +C +C Symplectic reflection to zero (H*H)(J+2:N,J). +C + CALL DLARFG( N-J, DWORK(J+1), DWORK(J+2), 1, TAU ) + DWORK(J+1) = ONE +C + CALL DLARFX( 'Left', N-J, N, DWORK(J+1), TAU, A(J+1,1), LDA, + $ DWORK(N+1) ) + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, A(1,J+1), LDA, + $ DWORK(N+1) ) +C + CALL DLARFX( 'Left', N-J, J, DWORK(J+1), TAU, QG(J+1,1), LDQG, + $ DWORK(N+1) ) + CALL DSYMV( 'Lower', N-J, TAU, QG(J+1,J+1), LDQG, DWORK(J+1), + $ 1, ZERO, DWORK(N+J+1), 1 ) + CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), + $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) + CALL DSYR2( 'Lower', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, + $ QG(J+1,J+1), LDQG ) +C + CALL DLARFX( 'Right', J, N-J, DWORK(J+1), TAU, QG(1,J+2), LDQG, + $ DWORK(N+1) ) + CALL DSYMV( 'Upper', N-J, TAU, QG(J+1,J+2), LDQG, DWORK(J+1), + $ 1, ZERO, DWORK(N+J+1), 1 ) + CALL DAXPY( N-J, -TAU*DDOT( N-J, DWORK(N+J+1), 1, DWORK(J+1), + $ 1 )/TWO, DWORK(J+1), 1, DWORK(N+J+1), 1 ) + CALL DSYR2( 'Upper', N-J, -ONE, DWORK(J+1), 1, DWORK(N+J+1), 1, + $ QG(J+1,J+2), LDQG ) +C + IF ( FORM ) THEN +C +C Save reflection. +C + CALL DCOPY( N-J, DWORK(J+1), 1, U(J+1,N+J), 1 ) + U(J+1,N+J) = TAU +C + ELSE IF ( ACCUM ) THEN +C +C Accumulate reflection. +C + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,J+1), + $ LDU, DWORK(N+1) ) + CALL DLARFX( 'Right', N, N-J, DWORK(J+1), TAU, U(1,N+J+1), + $ LDU, DWORK(N+1) ) + END IF +C + 10 CONTINUE +C + IF ( FORM ) THEN + DUMMY(1) = ZERO +C +C Form S by accumulating transformations. +C + DO 20 J = N - 1, 1, -1 +C +C Initialize (J+1)st column of S. +C + CALL DCOPY( N, DUMMY, 0, U(1,J+1), 1 ) + U(J+1,J+1) = ONE + CALL DCOPY( N, DUMMY, 0, U(1,N+J+1), 1 ) +C +C Second reflection. +C + TAU = U(J+1,N+J) + U(J+1,N+J) = ONE + CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, + $ U(J+1,J+1), LDU, DWORK(N+1) ) + CALL DLARFX( 'Left', N-J, N-J, U(J+1,N+J), TAU, + $ U(J+1,N+J+1), LDU, DWORK(N+1) ) +C +C Rotation. +C + CALL DROT( N-J, U(J+1,J+1), LDU, U(J+1,N+J+1), LDU, + $ U(J,J), U(J,N+J) ) +C +C First reflection. +C + TAU = U(J+1,J) + U(J+1,J) = ONE + CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, U(J+1,J+1), + $ LDU, DWORK(N+1) ) + CALL DLARFX( 'Left', N-J, N-J, U(J+1,J), TAU, + $ U(J+1,N+J+1), LDU, DWORK(N+1) ) + 20 CONTINUE +C +C The first column is the first column of identity. +C + CALL DCOPY( N, DUMMY, 0, U, 1 ) + U(1,1) = ONE + CALL DCOPY( N, DUMMY, 0, U(1,N+1), 1 ) + END IF +C + RETURN +C *** Last line of MB04ZD *** + END diff --git a/mex/sources/libslicot/MB05MD.f b/mex/sources/libslicot/MB05MD.f new file mode 100644 index 000000000..58da11528 --- /dev/null +++ b/mex/sources/libslicot/MB05MD.f @@ -0,0 +1,356 @@ + SUBROUTINE MB05MD( BALANC, N, DELTA, A, LDA, V, LDV, Y, LDY, VALR, + $ VALI, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute exp(A*delta) where A is a real N-by-N non-defective +C matrix with real or complex eigenvalues and delta is a scalar +C value. The routine also returns the eigenvalues and eigenvectors +C of A as well as (if all eigenvalues are real) the matrix product +C exp(Lambda*delta) times the inverse of the eigenvector matrix +C of A, where Lambda is the diagonal matrix of eigenvalues. +C Optionally, the routine computes a balancing transformation to +C improve the conditioning of the eigenvalues and eigenvectors. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALANC CHARACTER*1 +C Indicates how the input matrix should be diagonally scaled +C to improve the conditioning of its eigenvalues as follows: +C = 'N': Do not diagonally scale; +C = 'S': Diagonally scale the matrix, i.e. replace A by +C D*A*D**(-1), where D is a diagonal matrix chosen +C to make the rows and columns of A more equal in +C norm. Do not permute. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C DELTA (input) DOUBLE PRECISION +C The scalar value delta of the problem. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A of the problem. +C On exit, the leading N-by-N part of this array contains +C the solution matrix exp(A*delta). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C V (output) DOUBLE PRECISION array, dimension (LDV,N) +C The leading N-by-N part of this array contains the +C eigenvector matrix for A. +C If the k-th eigenvalue is real the k-th column of the +C eigenvector matrix holds the eigenvector corresponding +C to the k-th eigenvalue. +C Otherwise, the k-th and (k+1)-th eigenvalues form a +C complex conjugate pair and the k-th and (k+1)-th columns +C of the eigenvector matrix hold the real and imaginary +C parts of the eigenvectors corresponding to these +C eigenvalues as follows. +C If p and q denote the k-th and (k+1)-th columns of the +C eigenvector matrix, respectively, then the eigenvector +C corresponding to the complex eigenvalue with positive +C (negative) imaginary value is given by +C 2 +C p + q*j (p - q*j), where j = -1. +C +C LDV INTEGER +C The leading dimension of array V. LDV >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains an +C intermediate result for computing the matrix exponential. +C Specifically, exp(A*delta) is obtained as the product V*Y, +C where V is the matrix stored in the leading N-by-N part of +C the array V. If all eigenvalues of A are real, then the +C leading N-by-N part of this array contains the matrix +C product exp(Lambda*delta) times the inverse of the (right) +C eigenvector matrix of A, where Lambda is the diagonal +C matrix of eigenvalues. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= max(1,N). +C +C VALR (output) DOUBLE PRECISION array, dimension (N) +C VALI (output) DOUBLE PRECISION array, dimension (N) +C These arrays contain the real and imaginary parts, +C respectively, of the eigenvalues of the matrix A. The +C eigenvalues are unordered except that complex conjugate +C pairs of values appear consecutively with the eigenvalue +C having positive imaginary part first. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and if N > 0, DWORK(2) returns the reciprocal +C condition number of the triangular matrix used to obtain +C the inverse of the eigenvector matrix. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= max(1,4*N). +C For good performance, LDWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues; no eigenvectors have been computed; +C elements i+1:N of VALR and VALI contain eigenvalues +C which have converged; +C = N+1: if the inverse of the eigenvector matrix could not +C be formed due to an attempt to divide by zero, i.e., +C the eigenvector matrix is singular; +C = N+2: if the matrix A is defective, possibly due to +C rounding errors. +C +C METHOD +C +C This routine is an implementation of "Method 15" of the set of +C methods described in reference [1], which uses an eigenvalue/ +C eigenvector decomposition technique. A modification of LAPACK +C Library routine DGEEV is used for obtaining the right eigenvector +C matrix. A condition estimate is then employed to determine if the +C matrix A is near defective and hence the exponential solution is +C inaccurate. In this case the routine returns with the Error +C Indicator (INFO) set to N+2, and SLICOT Library routines MB05ND or +C MB05OD are the preferred alternative routines to be used. +C +C REFERENCES +C +C [1] Moler, C.B. and Van Loan, C.F. +C Nineteen dubious ways to compute the exponential of a matrix. +C SIAM Review, 20, pp. 801-836, 1978. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB05AD by M.J. Denham, Kingston +C Polytechnic, March 1981. +C +C REVISIONS +C +C V. Sima, June 13, 1997, April 25, 2003, Feb. 15, 2004. +C +C KEYWORDS +C +C Eigenvalue, eigenvector decomposition, matrix exponential. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC + INTEGER INFO, LDA, LDV, LDWORK, LDY, N + DOUBLE PRECISION DELTA +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), V(LDV,*), VALI(*), VALR(*), + $ Y(LDY,*) +C .. Local Scalars .. + LOGICAL SCALE + INTEGER I + DOUBLE PRECISION RCOND, TEMPI, TEMPR, WRKOPT +C .. Local Arrays .. + DOUBLE PRECISION TMP(2,2) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DGEBAK, DGEMM, DLACPY, DSCAL, DSWAP, DTRCON, + $ DTRMM, DTRSM, MB05MY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC COS, EXP, MAX, SIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + SCALE = LSAME( BALANC, 'S' ) + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDV.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB05MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C Compute the eigenvalues and right eigenvectors of the real +C nonsymmetric matrix A; optionally, compute a balancing +C transformation. +C Workspace: need: 4*N. +C + CALL MB05MY( BALANC, N, A, LDA, VALR, VALI, V, LDV, Y, LDY, + $ DWORK, LDWORK, INFO ) +C + IF ( INFO.GT.0 ) + $ RETURN + WRKOPT = DWORK(1) + IF ( SCALE ) THEN + DO 10 I = 1, N + DWORK(I) = DWORK(I+1) + 10 CONTINUE + END IF +C +C Exit with INFO = N + 1 if V is exactly singular. +C + DO 20 I = 1, N + IF ( V(I,I).EQ.ZERO ) THEN + INFO = N + 1 + RETURN + END IF + 20 CONTINUE +C +C Compute the reciprocal condition number of the triangular matrix. +C + CALL DTRCON( '1-norm', 'Upper', 'Non unit', N, V, LDV, RCOND, + $ DWORK(N+1), IWORK, INFO ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN + DWORK(2) = RCOND + INFO = N + 2 + RETURN + END IF +C +C Compute the right eigenvector matrix (temporarily) in A. +C + CALL DLACPY( 'Full', N, N, Y, LDY, A, LDA ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non unit', N, N, + $ ONE, V, LDV, A, LDA ) + IF ( SCALE ) + $ CALL DGEBAK( BALANC, 'Right', N, 1, N, DWORK, N, A, LDA, INFO ) +C +C Compute the inverse of the right eigenvector matrix, by solving +C a set of linear systems, V * X = Y' (if BALANC = 'N'). +C + DO 40 I = 2, N + CALL DSWAP( I-1, Y(I,1), LDY, Y(1,I), 1 ) + 40 CONTINUE +C + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non unit', N, N, + $ ONE, V, LDV, Y, LDY ) + IF( SCALE ) THEN +C + DO 60 I = 1, N + TEMPR = ONE / DWORK(I) + CALL DSCAL( N, TEMPR, Y(1,I), 1 ) + 60 CONTINUE +C + END IF +C +C Save the right eigenvector matrix in V. +C + CALL DLACPY( 'Full', N, N, A, LDA, V, LDV ) +C +C Premultiply the inverse eigenvector matrix by the exponential of +C quasi-diagonal matrix Lambda * DELTA, where Lambda is the matrix +C of eigenvalues. +C Note that only real arithmetic is used, taking the special storing +C of eigenvalues/eigenvectors into account. +C + I = 0 +C REPEAT + 80 CONTINUE + I = I + 1 + IF ( VALI(I).EQ.ZERO ) THEN + TEMPR = EXP( VALR(I)*DELTA ) + CALL DSCAL( N, TEMPR, Y(I,1), LDY ) + ELSE + TEMPR = VALR(I)*DELTA + TEMPI = VALI(I)*DELTA + TMP(1,1) = COS( TEMPI )*EXP( TEMPR ) + TMP(1,2) = SIN( TEMPI )*EXP( TEMPR ) + TMP(2,1) = -TMP(1,2) + TMP(2,2) = TMP(1,1) + CALL DLACPY( 'Full', 2, N, Y(I,1), LDY, DWORK, 2 ) + CALL DGEMM( 'No transpose', 'No transpose', 2, N, 2, ONE, + $ TMP, 2, DWORK, 2, ZERO, Y(I,1), LDY ) + I = I + 1 + END IF + IF ( I.LT.N ) GO TO 80 +C UNTIL I = N. +C +C Compute the matrix exponential as the product V * Y. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, V, LDV, + $ Y, LDY, ZERO, A, LDA ) +C +C Set optimal workspace dimension and reciprocal condition number. +C + DWORK(1) = WRKOPT + DWORK(2) = RCOND +C + RETURN +C *** Last line of MB05MD *** + END diff --git a/mex/sources/libslicot/MB05MY.f b/mex/sources/libslicot/MB05MY.f new file mode 100644 index 000000000..7d7063494 --- /dev/null +++ b/mex/sources/libslicot/MB05MY.f @@ -0,0 +1,327 @@ + SUBROUTINE MB05MY( BALANC, N, A, LDA, WR, WI, R, LDR, Q, LDQ, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for an N-by-N real nonsymmetric matrix A, the +C orthogonal matrix Q reducing it to real Schur form T, the +C eigenvalues, and the right eigenvectors of T. +C +C The right eigenvector r(j) of T satisfies +C T * r(j) = lambda(j) * r(j) +C where lambda(j) is its eigenvalue. +C +C The matrix of right eigenvectors R is upper triangular, by +C construction. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALANC CHARACTER*1 +C Indicates how the input matrix should be diagonally scaled +C to improve the conditioning of its eigenvalues as follows: +C = 'N': Do not diagonally scale; +C = 'S': Diagonally scale the matrix, i.e. replace A by +C D*A*D**(-1), where D is a diagonal matrix chosen +C to make the rows and columns of A more equal in +C norm. Do not permute. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the given matrix A. +C On exit, the leading N-by-N upper quasi-triangular part of +C this array contains the real Schur canonical form of A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C WR and WI contain the real and imaginary parts, +C respectively, of the computed eigenvalues. Complex +C conjugate pairs of eigenvalues appear consecutively +C with the eigenvalue having the positive imaginary part +C first. +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N) +C The leading N-by-N upper triangular part of this array +C contains the matrix of right eigenvectors R, in the same +C order as their eigenvalues. The real and imaginary parts +C of a complex eigenvector corresponding to an eigenvalue +C with positive imaginary part are stored in consecutive +C columns. (The corresponding conjugate eigenvector is not +C stored.) The eigenvectors are not backward transformed +C for balancing (when BALANC = 'S'). +C +C LDR INTEGER +C The leading dimension of array R. LDR >= max(1,N). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C The leading N-by-N part of this array contains the +C orthogonal matrix Q which has reduced A to real Schur +C form. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK. +C If BALANC = 'S', DWORK(2),...,DWORK(N+1) return the +C scaling factors used for balancing. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= max(1,4*N). +C For good performance, LDWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues, and no eigenvectors have been +C computed; elements i+1:N of WR and WI contain +C eigenvalues which have converged. +C +C METHOD +C +C This routine uses the QR algorithm to obtain the real Schur form +C T of matrix A. Then, the right eigenvectors of T are computed, +C but they are not backtransformed into the eigenvectors of A. +C MB05MY is a modification of the LAPACK driver routine DGEEV. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB05AY. +C +C REVISIONS +C +C V. Sima, April 25, 2003, Feb. 15, 2004. +C +C KEYWORDS +C +C Eigenvalue, eigenvector decomposition, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC + INTEGER INFO, LDA, LDQ, LDR, LDWORK, N +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), DWORK( * ), Q( LDQ, * ), + $ R( LDR, * ), WI( * ), WR( * ) +C .. +C .. Local Scalars .. + LOGICAL SCALE, SCALEA + INTEGER HSDWOR, IBAL, IERR, IHI, ILO, ITAU, JWORK, K, + $ MAXB, MAXWRK, MINWRK, NOUT + DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM +C .. +C .. Local Arrays .. + LOGICAL SELECT( 1 ) + DOUBLE PRECISION DUM( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY, DLASCL, + $ DORGHR, DTREVC, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + SCALE = LSAME( BALANC, 'S' ) + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. SCALE ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV. +C HSDWOR refers to the workspace preferred by DHSEQR, as +C calculated below. HSDWOR is computed assuming ILO=1 and IHI=N, +C the worst case.) +C + MINWRK = 1 + IF( INFO.EQ.0 .AND. LDWORK.GE.1 ) THEN + MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ) + MINWRK = MAX( 1, 4*N ) + MAXWRK = MAX( MAXWRK, 2*N+( N-1 )* + $ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) ) + MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 ) + K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1, + $ N, -1 ) ) ) + HSDWOR = MAX( K*( K+2 ), 2*N ) + MAXWRK = MAX( MAXWRK, N+1, N+HSDWOR ) + MAXWRK = MAX( MAXWRK, 4*N ) + DWORK( 1 ) = MAXWRK + END IF + IF( LDWORK.LT.MINWRK ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB05MY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Get machine constants. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SQRT( SMLNUM ) / EPS + BIGNUM = ONE / SMLNUM +C +C Scale A if max element outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'M', N, N, A, LDA, DUM ) + SCALEA = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + SCALEA = .TRUE. + CSCALE = SMLNUM + ELSE IF( ANRM.GT.BIGNUM ) THEN + SCALEA = .TRUE. + CSCALE = BIGNUM + END IF + IF( SCALEA ) + $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR ) +C +C Balance the matrix, if requested. (Permutation is not possible.) +C (Workspace: need N) +C + IBAL = 1 + CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, DWORK( IBAL ), IERR ) +C +C Reduce to upper Hessenberg form. +C (Workspace: need 3*N, prefer 2*N+N*NB) +C + ITAU = IBAL + N + JWORK = ITAU + N + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK( ITAU ), DWORK( JWORK ), + $ LDWORK-JWORK+1, IERR ) +C +C Compute right eigenvectors of T. +C Copy Householder vectors to Q. +C + CALL DLACPY( 'Lower', N, N, A, LDA, Q, LDQ ) +C +C Generate orthogonal matrix in Q. +C (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) +C + CALL DORGHR( N, ILO, IHI, Q, LDQ, DWORK( ITAU ), DWORK( JWORK ), + $ LDWORK-JWORK+1, IERR ) +C +C Perform QR iteration, accumulating Schur vectors in Q. +C (Workspace: need N+1, prefer N+HSDWOR (see comments) ) +C + JWORK = ITAU + CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, Q, LDQ, + $ DWORK( JWORK ), LDWORK-JWORK+1, INFO ) +C +C If INFO > 0 from DHSEQR, then quit. +C + IF( INFO.GT.0 ) + $ GO TO 10 +C +C Compute right eigenvectors of T in R. +C (Workspace: need 4*N) +C + CALL DTREVC( 'Right', 'All', SELECT, N, A, LDA, DUM, 1, R, LDR, N, + $ NOUT, DWORK( JWORK ), IERR ) +C +C Undo scaling if necessary. +C + 10 CONTINUE + IF( SCALEA ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ), + $ MAX( N-INFO, 1 ), IERR ) + IF( INFO.GT.0 ) THEN + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N, + $ IERR ) + CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N, + $ IERR ) + END IF + END IF +C + IF ( SCALE ) THEN + DO 20 K = N, 1, -1 + DWORK( K+1 ) = DWORK( K ) + 20 CONTINUE + END IF + DWORK( 1 ) = MAXWRK +C + RETURN +C *** Last line of MB05MY *** + END diff --git a/mex/sources/libslicot/MB05ND.f b/mex/sources/libslicot/MB05ND.f new file mode 100644 index 000000000..37bbe61a6 --- /dev/null +++ b/mex/sources/libslicot/MB05ND.f @@ -0,0 +1,377 @@ + SUBROUTINE MB05ND( N, DELTA, A, LDA, EX, LDEX, EXINT, LDEXIN, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute +C +C (a) F(delta) = exp(A*delta) and +C +C (b) H(delta) = Int[F(s) ds] from s = 0 to s = delta, +C +C where A is a real N-by-N matrix and delta is a scalar value. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C DELTA (input) DOUBLE PRECISION +C The scalar value delta of the problem. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C matrix A of the problem. (Array A need not be set if +C DELTA = 0.) +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,N). +C +C EX (output) DOUBLE PRECISION array, dimension (LDEX,N) +C The leading N-by-N part of this array contains an +C approximation to F(delta). +C +C LDEX INTEGER +C The leading dimension of array EX. LDEX >= MAX(1,N). +C +C EXINT (output) DOUBLE PRECISION array, dimension (LDEXIN,N) +C The leading N-by-N part of this array contains an +C approximation to H(delta). +C +C LDEXIN INTEGER +C The leading dimension of array EXINT. LDEXIN >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the order of the +C Pade approximation to H(t), where t is a scale factor +C determined by the routine. A reasonable value for TOL may +C be SQRT(EPS), where EPS is the machine precision (see +C LAPACK Library routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N*(N+1)). +C For optimum performance LDWORK should be larger (2*N*N). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the (i,i) element of the denominator of +C the Pade approximation is zero, so the denominator +C is exactly singular; +C = N+1: if DELTA = (delta * frobenius norm of matrix A) is +C probably too large to permit meaningful computation. +C That is, DELTA > SQRT(BIG), where BIG is a +C representable number near the overflow threshold of +C the machine (see LAPACK Library Routine DLAMCH). +C +C METHOD +C +C This routine uses a Pade approximation to H(t) for some small +C value of t (where 0 < t <= delta) and then calculates F(t) from +C H(t). Finally, the results are re-scaled to give F(delta) and +C H(delta). For a detailed description of the implementation of this +C algorithm see [1]. +C +C REFERENCES +C +C [1] Benson, C.J. +C The numerical evaluation of the matrix exponential and its +C integral. +C Report 82/03, Control Systems Research Group, +C School of Electronic Engineering and Computer +C Science, Kingston Polytechnic, January 1982. +C +C [2] Ward, R.C. +C Numerical computation of the matrix exponential with accuracy +C estimate. +C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. +C +C [3] Moler, C.B. and Van Loan, C.F. +C Nineteen Dubious Ways to Compute the Exponential of a Matrix. +C SIAM Rev., 20, pp. 801-836, 1978. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine MB05BD by C.J. Benson, Kingston +C Polytechnic, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Continuous-time system, matrix algebra, matrix exponential, +C matrix operations, Pade approximation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, ONE64, THREE, FOUR8 + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ ONE64 = 1.64D0, THREE = 3.0D0, FOUR8 = 4.8D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDEX, LDEXIN, LDWORK, N + DOUBLE PRECISION DELTA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), EX(LDEX,*), EXINT(LDEXIN,*) +C .. Local Scalars .. + INTEGER I, I2IQ1, IJ, IQ, J, JSCAL, KK, L, NN + DOUBLE PRECISION COEFFD, COEFFN, DELSC, EPS, ERR, F2IQ1, + $ FNORM, FNORM2, QMAX, SMALL +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGESV, DLACPY, + $ DLASET, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, EXP, MAX, MOD, SQRT +C .. Executable Statements .. +C + INFO = 0 + NN = N*N +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDEX.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDEXIN.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDWORK.LT.MAX( 1, NN + N ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB05ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + DWORK(1) = ONE + IF ( N.EQ.0 ) + $ RETURN +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, EX, LDEX ) + CALL DLASET( 'Full', N, N, ZERO, ZERO, EXINT, LDEXIN ) +C + IF ( DELTA.EQ.ZERO ) THEN + CALL DLASET( 'Upper', N, N, ZERO, ONE, EX, LDEX ) + RETURN + END IF +C + IF ( N.EQ.1 ) THEN + EX(1,1) = EXP( DELTA*A(1,1) ) + IF ( A(1,1).EQ.ZERO ) THEN + EXINT(1,1) = DELTA + ELSE + EXINT(1,1) = ( ( ONE/A(1,1) )*EX(1,1) ) - ( ONE/A(1,1) ) + END IF + RETURN + END IF +C +C Set some machine parameters. +C + EPS = DLAMCH( 'Epsilon' ) + SMALL = DLAMCH( 'Safe minimum' )/EPS +C +C First calculate the Frobenius norm of A, and the scaling factor. +C + FNORM = DELTA*DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) +C + IF ( FNORM.GT.SQRT( ONE/SMALL ) ) THEN + INFO = N + 1 + RETURN + END IF +C + JSCAL = 0 + DELSC = DELTA +C WHILE ( FNORM >= HALF ) DO + 20 CONTINUE + IF ( FNORM.GE.HALF ) THEN + JSCAL = JSCAL + 1 + DELSC = DELSC*HALF + FNORM = FNORM*HALF + GO TO 20 + END IF +C END WHILE 20 +C +C Calculate the order of the Pade approximation needed to satisfy +C the requested relative error TOL. +C + FNORM2 = FNORM**2 + IQ = 1 + QMAX = FNORM/THREE + ERR = DELTA/DELSC*FNORM2**2/FOUR8 +C WHILE ( ERR > TOL*( 2*IQ + 3 - FNORM )/1.64 and QMAX >= EPS ) DO + 40 CONTINUE + IF ( ERR.GT.TOL*( DBLE( 2*IQ + 3 ) - FNORM )/ONE64 ) THEN + IQ = IQ + 1 + QMAX = QMAX*DBLE( IQ + 1 )*FNORM/DBLE( 2*IQ*( 2*IQ + 1 ) ) + IF ( QMAX.GE.EPS ) THEN + ERR = ERR*FNORM2*DBLE( 2*IQ + 5 )/DBLE( ( 2*IQ + 3 )**2 + $ *( 2*IQ + 4 ) ) + GO TO 40 + END IF + END IF +C END WHILE 40 +C +C Initialise DWORK (to contain succesive powers of A), +C EXINT (to contain the numerator) and +C EX (to contain the denominator). +C + I2IQ1 = 2*IQ + 1 + F2IQ1 = DBLE( I2IQ1 ) + COEFFD = -DBLE( IQ )/F2IQ1 + COEFFN = HALF/F2IQ1 + IJ = 1 +C + DO 80 J = 1, N +C + DO 60 I = 1, N + DWORK(IJ) = DELSC*A(I,J) + EXINT(I,J) = COEFFN*DWORK(IJ) + EX(I,J) = COEFFD*DWORK(IJ) + IJ = IJ + 1 + 60 CONTINUE +C + EXINT(J,J) = EXINT(J,J) + ONE + EX(J,J) = EX(J,J) + ONE + 80 CONTINUE +C + DO 140 KK = 2, IQ +C +C Calculate the next power of A*DELSC, and update the numerator +C and denominator. +C + COEFFD = -COEFFD*DBLE( IQ+1-KK )/DBLE( KK*( I2IQ1+1-KK ) ) + IF ( MOD( KK, 2 ).EQ.0 ) THEN + COEFFN = COEFFD/DBLE( KK + 1 ) + ELSE + COEFFN = -COEFFD/DBLE( I2IQ1 - KK ) + END IF + IJ = 1 +C + IF ( LDWORK.GE.2*NN ) THEN +C +C Enough space for a BLAS 3 calculation. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, DELSC, + $ A, LDA, DWORK, N, ZERO, DWORK(NN+1), N ) + CALL DCOPY( NN, DWORK(NN+1), 1, DWORK, 1 ) +C + DO 100 J = 1, N + CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) + CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) + IJ = IJ + N + 100 CONTINUE +C + ELSE +C +C Not enough space for a BLAS 3 calculation. Use BLAS 2. +C + DO 120 J = 1, N + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, DWORK(IJ), + $ 1, ZERO, DWORK(NN+1), 1 ) + CALL DCOPY( N, DWORK(NN+1), 1, DWORK(IJ), 1 ) + CALL DSCAL( N, DELSC, DWORK(IJ), 1 ) + CALL DAXPY( N, COEFFN, DWORK(IJ), 1, EXINT(1,J), 1 ) + CALL DAXPY( N, COEFFD, DWORK(IJ), 1, EX(1,J), 1 ) + IJ = IJ + N + 120 CONTINUE +C + END IF + 140 CONTINUE +C +C We now have numerator in EXINT, denominator in EX. +C +C Solve the set of N systems of linear equations for the columns of +C EXINT using the LU factorization of EX. +C + CALL DGESV( N, N, EX, LDEX, IWORK, EXINT, LDEXIN, INFO ) + IF ( INFO.NE.0 ) + $ RETURN +C +C Now we can form EX from EXINT using the formula: +C EX = EXINT * A + I +C + DO 160 J = 1, N + CALL DSCAL( N, DELSC, EXINT(1,J), 1 ) + 160 CONTINUE +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, EXINT, + $ LDEXIN, A, LDA, ZERO, EX, LDEX ) +C + DO 180 J = 1, N + EX(J,J) = EX(J,J) + ONE + 180 CONTINUE +C +C EX and EXINT have been evaluated at DELSC, so the results +C must be re-scaled to give the function values at DELTA. +C +C EXINT(2t) = EXINT(t) * ^ EX(t) + I [ +C EX(2t) = EX(t) * EX(t) +C +C DWORK is used to accumulate products. +C + DO 200 L = 1, JSCAL + CALL DLACPY( 'Full', N, N, EXINT, LDEXIN, DWORK, N ) + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ DWORK, N, EX, LDEX, ONE, EXINT, LDEXIN ) + CALL DLACPY( 'Full', N, N, EX, LDEX, DWORK, N ) + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ DWORK, N, DWORK, N, ZERO, EX, LDEX ) + 200 CONTINUE +C + DWORK(1) = 2*NN + RETURN +C *** Last line of MB05ND *** + END diff --git a/mex/sources/libslicot/MB05OD.f b/mex/sources/libslicot/MB05OD.f new file mode 100644 index 000000000..ec87a2ee7 --- /dev/null +++ b/mex/sources/libslicot/MB05OD.f @@ -0,0 +1,574 @@ + SUBROUTINE MB05OD( BALANC, N, NDIAG, DELTA, A, LDA, MDIG, IDIG, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute exp(A*delta) where A is a real N-by-N matrix and delta +C is a scalar value. The routine also returns the minimal number of +C accurate digits in the 1-norm of exp(A*delta) and the number of +C accurate digits in the 1-norm of exp(A*delta) at 95% confidence +C level. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALANC CHARACTER*1 +C Specifies whether or not a balancing transformation (done +C by SLICOT Library routine MB04MD) is required, as follows: +C = 'N', do not use balancing; +C = 'S', use balancing (scaling). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C NDIAG (input) INTEGER +C The specified order of the diagonal Pade approximant. +C In the absence of further information NDIAG should +C be set to 9. NDIAG should not exceed 15. NDIAG >= 1. +C +C DELTA (input) DOUBLE PRECISION +C The scalar value delta of the problem. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On input, the leading N-by-N part of this array must +C contain the matrix A of the problem. (This is not needed +C if DELTA = 0.) +C On exit, if INFO = 0, the leading N-by-N part of this +C array contains the solution matrix exp(A*delta). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C MDIG (output) INTEGER +C The minimal number of accurate digits in the 1-norm of +C exp(A*delta). +C +C IDIG (output) INTEGER +C The number of accurate digits in the 1-norm of +C exp(A*delta) at 95% confidence level. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= N*(2*N+NDIAG+1)+NDIAG, if N > 1. +C LDWORK >= 1, if N <= 1. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: if MDIG = 0 and IDIG > 0, warning for possible +C inaccuracy (the exponential has been computed); +C = 2: if MDIG = 0 and IDIG = 0, warning for severe +C inaccuracy (the exponential has been computed); +C = 3: if balancing has been requested, but it failed to +C reduce the matrix norm and was not actually used. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the norm of matrix A*delta (after a possible +C balancing) is too large to obtain an accurate +C result; +C = 2: if the coefficient matrix (the denominator of the +C Pade approximant) is exactly singular; try a +C different value of NDIAG; +C = 3: if the solution exponential would overflow, possibly +C due to a too large value DELTA; the calculations +C stopped prematurely. This error is not likely to +C appear. +C +C METHOD +C +C The exponential of the matrix A is evaluated from a diagonal Pade +C approximant. This routine is a modification of the subroutine +C PADE, described in reference [1]. The routine implements an +C algorithm which exploits the identity +C +C (exp[(2**-m)*A]) ** (2**m) = exp(A), +C +C where m is an integer determined by the algorithm, to improve the +C accuracy for matrices with large norms. +C +C REFERENCES +C +C [1] Ward, R.C. +C Numerical computation of the matrix exponential with accuracy +C estimate. +C SIAM J. Numer. Anal., 14, pp. 600-610, 1977. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB05CD by T.W.C. Williams, Kingston +C Polytechnic, March 1982. +C +C REVISIONS +C +C June 14, 1997, April 25, 2003, December 12, 2004. +C +C KEYWORDS +C +C Continuous-time system, matrix algebra, matrix exponential, +C matrix operations, Pade approximation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, EIGHT, TEN, TWELVE, + $ NINTEN, TWO4, FOUR7, TWOHND + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ TWO = 2.0D0, FOUR = 4.0D0, EIGHT = 8.0D0, + $ TEN = 10.0D0, TWELVE = 12.0D0, + $ NINTEN = 19.0D0, TWO4 = 24.0D0, + $ FOUR7 = 47.0D0, TWOHND = 200.0D0 ) +C .. Scalar Arguments .. + CHARACTER BALANC + INTEGER IDIG, INFO, IWARN, LDA, LDWORK, MDIG, N, + $ NDIAG + DOUBLE PRECISION DELTA +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LBALS + CHARACTER ACTBAL + INTEGER BASE, I, IFAIL, IJ, IK, IM1, J, JWORA1, JWORA2, + $ JWORA3, JWORV1, JWORV2, K, M, MPOWER, NDAGM1, + $ NDAGM2, NDEC, NDECM1 + DOUBLE PRECISION ANORM, AVGEV, BD, BIG, EABS, EAVGEV, EMNORM, + $ EPS, FACTOR, FN, GN, MAXRED, OVRTH2, OVRTHR, P, + $ RERL, RERR, S, SD2, SIZE, SMALL, SS, SUM2D, + $ TEMP, TMP1, TR, U, UNDERF, VAR, VAREPS, XN +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DNRM2 + EXTERNAL DASUM, DLAMCH, DLANGE, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGETRF, DGETRS, DLACPY, + $ DLASCL, DLASET, DSCAL, MB04MD, MB05OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, EXP, INT, LOG, LOG10, MAX, MIN, MOD, SQRT +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + LBALS = LSAME( BALANC, 'S' ) +C +C Test the input scalar arguments. +C + IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LBALS ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NDIAG.LT.1 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDWORK.LT.1 .OR. + $ ( LDWORK.LT.N*( 2*N + NDIAG + 1 ) + NDIAG .AND. N.GT.1 ) + $ ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MB05OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + EPS = DLAMCH( 'Epsilon' ) + NDEC = INT( LOG10( ONE/EPS ) + ONE ) +C + IF ( N.EQ.0 ) THEN + MDIG = NDEC + IDIG = NDEC + RETURN + END IF +C +C Set some machine parameters. +C + BASE = DLAMCH( 'Base' ) + NDECM1 = NDEC - 1 + UNDERF = DLAMCH( 'Underflow' ) + OVRTHR = DLAMCH( 'Overflow' ) + OVRTH2 = SQRT( OVRTHR ) +C + IF ( DELTA.EQ.ZERO ) THEN +C +C The DELTA = 0 case. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, A, LDA ) + MDIG = NDECM1 + IDIG = NDECM1 + RETURN + END IF +C + IF ( N.EQ.1 ) THEN +C +C The 1-by-1 case. +C + A(1,1) = EXP( A(1,1)*DELTA ) + MDIG = NDECM1 + IDIG = NDECM1 + RETURN + END IF +C +C Set pointers for the workspace. +C + JWORA1 = 1 + JWORA2 = JWORA1 + N*N + JWORA3 = JWORA2 + N*NDIAG + JWORV1 = JWORA3 + N*N + JWORV2 = JWORV1 + N +C +C Compute Pade coefficients in DWORK(JWORV2:JWORV2+NDIAG-1). +C + DWORK(JWORV2) = HALF +C + DO 20 I = 2, NDIAG + IM1 = I - 1 + DWORK(JWORV2+IM1) = DWORK(JWORV2+I-2)*DBLE( NDIAG - IM1 )/ + $ DBLE( I*( 2*NDIAG - IM1 ) ) + 20 CONTINUE +C + VAREPS = EPS**2*( ( DBLE( BASE )**2 - ONE )/ + $ ( TWO4*LOG( DBLE( BASE ) ) ) ) + XN = DBLE( N ) + TR = ZERO +C +C Apply a translation with the mean of the eigenvalues of A*DELTA. +C + DO 40 I = 1, N + CALL DSCAL( N, DELTA, A(1,I), 1 ) + TR = TR + A(I,I) + 40 CONTINUE +C + AVGEV = TR/XN + IF ( AVGEV.GT.LOG( OVRTHR ) .OR. AVGEV.LT.LOG( UNDERF ) ) + $ AVGEV = ZERO + IF ( AVGEV.NE.ZERO ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) +C + DO 60 I = 1, N + A(I,I) = A(I,I) - AVGEV + 60 CONTINUE +C + TEMP = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) + IF ( TEMP.GT.HALF*ANORM ) THEN +C + DO 80 I = 1, N + A(I,I) = A(I,I) + AVGEV + 80 CONTINUE +C + AVGEV = ZERO + END IF + END IF + ACTBAL = BALANC + IF ( LBALS ) THEN +C +C Balancing (scaling) has been requested. First, save A. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(JWORA1), N ) + MAXRED = TWOHND + CALL MB04MD( N, MAXRED, A, LDA, DWORK(JWORV1), INFO ) + IF ( MAXRED.LT.ONE ) THEN +C +C Recover the matrix and reset DWORK(JWORV1,...,JWORV1+N-1) +C to 1, as no reduction of the norm occured (unlikely event). +C + CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) + ACTBAL = 'N' + DWORK(JWORV1) = ONE + CALL DCOPY( N-1, DWORK(JWORV1), 0, DWORK(JWORV1+1), 1 ) + IWARN = 3 + END IF + END IF +C +C Scale the matrix by 2**(-M), where M is the minimum integer +C so that the resulted matrix has the 1-norm less than 0.5. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) + M = 0 + IF ( ANORM.GE.HALF ) THEN + MPOWER = INT( LOG( OVRTHR )/LOG( TWO ) ) + M = INT( LOG( ANORM )/LOG( TWO ) ) + 1 + IF ( M.GT.MPOWER ) THEN +C +C Error return: The norm of A*DELTA is too large. +C + INFO = 1 + RETURN + END IF + FACTOR = TWO**M + IF ( M+1.LT.MPOWER ) THEN + M = M + 1 + FACTOR = FACTOR*TWO + END IF +C + DO 120 I = 1, N + CALL DSCAL( N, ONE/FACTOR, A(1,I), 1 ) + 120 CONTINUE +C + END IF + NDAGM1 = NDIAG - 1 + NDAGM2 = NDAGM1 - 1 + IJ = 0 +C +C Compute the factors of the diagonal Pade approximant. +C The loop 200 takes the accuracy requirements into account: +C Pade coefficients decrease with K, so the calculations should +C be performed in backward order, one column at a time. +C (A BLAS 3 implementation in forward order, using DGEMM, could +C possibly be less accurate.) +C + DO 200 J = 1, N + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, A(1,J), 1, ZERO, + $ DWORK(JWORA2), 1 ) + IK = 0 +C + DO 140 K = 1, NDAGM2 + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK(JWORA2+IK), 1, ZERO, DWORK(JWORA2+IK+N), + $ 1 ) + IK = IK + N + 140 CONTINUE +C + DO 180 I = 1, N + S = ZERO + U = ZERO + IK = NDAGM2*N + I - 1 +C + DO 160 K = NDAGM1, 1, -1 + P = DWORK(JWORV2+K)*DWORK(JWORA2+IK) + IK = IK - N + S = S + P + IF ( MOD( K+1, 2 ).EQ.0 ) THEN + U = U + P + ELSE + U = U - P + END IF + 160 CONTINUE +C + P = DWORK(JWORV2)*A(I,J) + S = S + P + U = U - P + IF ( I.EQ.J ) THEN + S = S + ONE + U = U + ONE + END IF + DWORK(JWORA3+IJ) = S + DWORK(JWORA1+IJ) = U + IJ = IJ + 1 + 180 CONTINUE +C + 200 CONTINUE +C +C Compute the exponential of the scaled matrix, using diagonal Pade +C approximants. As, in theory [1], the denominator of the Pade +C approximant should be very well conditioned, no condition estimate +C is computed. +C + CALL DGETRF( N, N, DWORK(JWORA1), N, IWORK, IFAIL ) + IF ( IFAIL.GT.0 ) THEN +C +C Error return: The matrix is exactly singular. +C + INFO = 2 + RETURN + END IF +C + CALL DLACPY( 'Full', N, N, DWORK(JWORA3), N, A, LDA ) + CALL DGETRS( 'No transpose', N, N, DWORK(JWORA1), N, IWORK, A, + $ LDA, IFAIL ) +C +C Prepare for the calculation of the accuracy estimates. +C Note that ANORM here is in the range [1, e]. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) + IF ( ANORM.GE.ONE ) THEN + EABS = ( NINTEN*XN + FOUR7 )*( EPS*ANORM ) + ELSE + EABS = ( ( NINTEN*XN + FOUR7 )*EPS )*ANORM + END IF + IF ( M.NE.0 ) THEN + VAR = XN*VAREPS + FN = ( FOUR*XN )/( ( XN + TWO )*( XN + ONE ) ) + GN = ( ( TWO*XN + TEN )*XN - FOUR )/( ( ( XN + TWO )**2 ) + $ *( ( XN + ONE )**2 ) ) +C +C Square-up the computed exponential matrix M times, with caution +C for avoiding overflows. +C + DO 220 K = 1, M + IF ( ANORM.GT.OVRTH2 ) THEN +C +C The solution could overflow. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, + $ ONE/ANORM, A, LDA, A, LDA, ZERO, + $ DWORK(JWORA1), N ) + S = DLANGE( '1-norm', N, N, DWORK(JWORA1), N, + $ DWORK(JWORA1) ) + IF ( ANORM.LE.OVRTHR/S ) THEN + CALL DLASCL( 'General', N, N, ONE, ANORM, N, N, + $ DWORK(JWORA1), N, INFO ) + TEMP = OVRTHR + ELSE +C +C Error return: The solution would overflow. +C This will not happen on most machines, due to the +C selection of M. +C + INFO = 3 + RETURN + END IF + ELSE + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ A, LDA, A, LDA, ZERO, DWORK(JWORA1), N ) + TEMP = ANORM**2 + END IF + IF ( EABS.LT.ONE ) THEN + EABS = ( TWO*ANORM + EABS )*EABS + XN*( EPS*TEMP ) + ELSE IF ( EABS.LT.SQRT( ONE - XN*EPS + OVRTHR/TEMP )*ANORM - + $ ANORM ) THEN + EABS = XN*( EPS*TEMP ) + TWO*( ANORM*EABS ) + EABS**2 + ELSE + EABS = OVRTHR + END IF +C + TMP1 = FN*VAR + GN*( TEMP*VAREPS ) + IF ( TMP1.GT.OVRTHR/TEMP ) THEN + VAR = OVRTHR + ELSE + VAR = TMP1*TEMP + END IF +C + CALL DLACPY( 'Full', N, N, DWORK(JWORA1), N, A, LDA ) + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) + 220 CONTINUE +C + ELSE + VAR = ( TWELVE*XN )*VAREPS + END IF +C +C Apply back transformations, if balancing was effectively used. +C + CALL MB05OY( ACTBAL, N, 1, N, A, LDA, DWORK(JWORV1), INFO ) + EAVGEV = EXP( AVGEV ) + EMNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK(JWORA1) ) +C +C Compute auxiliary quantities needed for the accuracy estimates. +C + BIG = ONE + SMALL = ONE + IF ( LBALS ) THEN +C +C Compute norms of the diagonal scaling matrix and its inverse. +C + DO 240 I = 1, N + U = DWORK(JWORV1+I-1) + IF ( BIG.LT.U ) BIG = U + IF ( SMALL.GT.U ) SMALL = U + 240 CONTINUE +C + SUM2D = DNRM2( N, DWORK(JWORV1), 1 ) + ELSE + SUM2D = SQRT( XN ) + END IF +C +C Update the exponential for the initial translation, and update the +C auxiliary quantities needed for the accuracy estimates. +C + SD2 = SQRT( EIGHT*XN*VAREPS )*ANORM + BD = SQRT( VAR ) + SS = MAX( BD, SD2 ) + BD = MIN( BD, SD2 ) + SD2 = SS*SQRT( ONE + ( BD/SS )**2 ) + IF ( SD2.LE.ONE ) THEN + SD2 = ( TWO/XN )*SUM2D*SD2 + ELSE IF ( SUM2D/XN.LT.OVRTHR/TWO/SD2 ) THEN + SD2 = ( TWO/XN )*SUM2D*SD2 + ELSE + SD2 = OVRTHR + END IF + IF ( LBALS ) THEN + SIZE = ZERO + ELSE + IF ( SD2.LT.OVRTHR - EMNORM ) THEN + SIZE = EMNORM + SD2 + ELSE + SIZE = OVRTHR + END IF + END IF +C + DO 260 J = 1, N + SS = DASUM( N, A(1,J), 1 ) + CALL DSCAL( N, EAVGEV, A(1,J), 1 ) + IF ( LBALS ) THEN + BD = DWORK(JWORV1+J-1) + SIZE = MAX( SIZE, SS + SD2/BD ) + END IF + 260 CONTINUE +C +C Set the accuracy estimates and warning errors, if any. +C + RERR = LOG10( BIG ) + LOG10( EABS ) - LOG10( SMALL ) - + $ LOG10( EMNORM ) - LOG10( EPS ) + IF ( SIZE.GT.EMNORM ) THEN + RERL = LOG10( ( SIZE/EMNORM - ONE )/EPS ) + ELSE + RERL = ZERO + END IF + MDIG = MIN( NDEC - INT( RERR + HALF ), NDECM1 ) + IDIG = MIN( NDEC - INT( RERL + HALF ), NDECM1 ) +C + IF ( MDIG.LE.0 ) THEN + MDIG = 0 + IWARN = 1 + END IF + IF ( IDIG.LE.0 ) THEN + IDIG = 0 + IWARN = 2 + END IF +C + RETURN +C *** Last line of MB05OD *** + END diff --git a/mex/sources/libslicot/MB05OY.f b/mex/sources/libslicot/MB05OY.f new file mode 100644 index 000000000..a73de7039 --- /dev/null +++ b/mex/sources/libslicot/MB05OY.f @@ -0,0 +1,179 @@ + SUBROUTINE MB05OY( JOB, N, LOW, IGH, A, LDA, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To restore a matrix after it has been transformed by applying +C balancing transformations (permutations and scalings), as +C determined by LAPACK Library routine DGEBAL. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the type of backward transformation required, +C as follows: +C = 'N', do nothing, return immediately; +C = 'P', do backward transformation for permutation only; +C = 'S', do backward transformation for scaling only; +C = 'B', do backward transformations for both permutation +C and scaling. +C JOB must be the same as the argument JOB supplied +C to DGEBAL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C LOW (input) INTEGER +C IGH (input) INTEGER +C The integers LOW and IGH determined by DGEBAL. +C 1 <= LOW <= IGH <= N, if N > 0; LOW=1 and IGH=0, if N=0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix to be back-transformed. +C On exit, the leading N-by-N part of this array contains +C the transformed matrix. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C SCALE (input) DOUBLE PRECISION array, dimension (N) +C Details of the permutation and scaling factors, as +C returned by DGEBAL. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Let P be a permutation matrix, and D a diagonal matrix of scaling +C factors, both of order N. The routine computes +C -1 +C A <-- P D A D P'. +C +C where the permutation and scaling factors are encoded in the +C array SCALE. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires O(N ) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997. +C Supersedes Release 2.0 routine MB05CY. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER IGH, INFO, LDA, LOW, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), SCALE(*) +C .. Local Scalars .. + INTEGER I, II, J, K +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DSCAL, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND. + $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 )THEN + INFO = -2 + ELSE IF( LOW.LT.1 .OR. LOW.GT.MAX( 1, N ) ) THEN + INFO = -3 + ELSE IF( IGH.LT.MIN( LOW, N ) .OR. IGH.GT.N ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB05OY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. LSAME( JOB, 'N' ) ) + $ RETURN +C + IF ( .NOT.LSAME( JOB, 'P' ) .AND. IGH.NE.LOW ) THEN +C + DO 20 I = LOW, IGH + CALL DSCAL( N, SCALE(I), A(I,1), LDA ) + 20 CONTINUE +C + DO 40 J = LOW, IGH + CALL DSCAL( N, ONE/SCALE(J), A(1,J), 1 ) + 40 CONTINUE +C + END IF +C + IF( .NOT.LSAME( JOB, 'S' ) ) THEN +C + DO 60 II = 1, N + I = II + IF ( I.LT.LOW .OR. I.GT.IGH ) THEN + IF ( I.LT.LOW ) I = LOW - II + K = SCALE(I) + IF ( K.NE.I ) THEN + CALL DSWAP( N, A(I,1), LDA, A(K,1), LDA ) + CALL DSWAP( N, A(1,I), 1, A(1,K), 1 ) + END IF + END IF + 60 CONTINUE +C + END IF +C + RETURN +C *** Last line of MB05OY *** + END diff --git a/mex/sources/libslicot/MB3OYZ.f b/mex/sources/libslicot/MB3OYZ.f new file mode 100644 index 000000000..054e570ad --- /dev/null +++ b/mex/sources/libslicot/MB3OYZ.f @@ -0,0 +1,395 @@ + SUBROUTINE MB3OYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, ZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a rank-revealing QR factorization of a complex general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated QR factorization with column pivoting +C [ R11 R12 ] +C A * P = Q * R, where R = [ ], +C [ 0 R22 ] +C with R11 defined as the largest leading upper triangular submatrix +C whose estimated condition number is less than 1/RCOND. The order +C of R11, RANK, is the effective rank of A. Condition estimation is +C performed during the QR factorization process. Matrix R22 is full +C (but of small norm), or empty. +C +C MB3OYZ does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) COMPLEX*16 array, dimension ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the leading RANK-by-RANK upper triangular part +C of A contains the triangular factor R11, and the elements +C below the diagonal in the first RANK columns, with the +C array TAU, represent the unitary matrix Q as a product +C of RANK elementary reflectors. +C The remaining N-RANK columns contain the result of the +C QR factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest leading triangular +C submatrix R11 in the QR factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R11. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of R(1:RANK,1:RANK); +C SVAL(2): smallest singular value of R(1:RANK,1:RANK); +C SVAL(3): smallest singular value of R(1:RANK+1,1:RANK+1), +C if RANK < MIN( M, N ), or of R(1:RANK,1:RANK), +C otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the leading columns were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(1:RANK,1:RANK). +C +C JPVT (output) INTEGER array, dimension ( N ) +C If JPVT(i) = k, then the i-th column of A*P was the k-th +C column of A. +C +C TAU (output) COMPLEX*16 array, dimension ( MIN( M, N ) ) +C The leading RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 2*N ) +C +C ZWORK COMPLEX*16 array, dimension ( 3*N-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of A, A * P = Q * R, with R defined above, and, +C during this process, finds the largest leading submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using the LAPACK incremental condition estimation scheme and a +C slightly modified rank decision test. The factorization process +C stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(1) H(2) . . . H(k), where k = rank <= min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a complex scalar, and v is a complex vector with +C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in +C A(i+1:m,i), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth column of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, unitary transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) + DOUBLE PRECISION DWORK( * ), SVAL( 3 ) +C .. +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, MN, PVT + COMPLEX*16 AII, C1, C2, S1, S2 + DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2, IDAMAX +C .. External Subroutines .. + EXTERNAL XERBLA, ZLAIC1, ZLARF, ZLARFG, ZSCAL, ZSWAP +C .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB3OYZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( M, N ) + IF( MN.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = 1 + ISMAX = ISMIN + N +C +C Initialize partial column norms and pivoting vector. The first n +C elements of DWORK store the exact column norms. +C + DO 10 I = 1, N + DWORK( I ) = DZNRM2( M, A( 1, I ), 1 ) + DWORK( N+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.MN ) THEN + I = RANK + 1 +C +C Determine ith pivot column and swap if necessary. +C + PVT = ( I-1 ) + IDAMAX( N-I+1, DWORK( I ), 1 ) +C + IF( PVT.NE.I ) THEN + CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + DWORK( PVT ) = DWORK( I ) + DWORK( N+PVT ) = DWORK( N+I ) + END IF +C +C Save A(I,I) and generate elementary reflector H(i) +C such that H(i)'*[A(i,i);*] = [*;0]. +C + IF( I.LT.M ) THEN + AII = A( I, I ) + CALL ZLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) ) + ELSE + TAU( M ) = CZERO + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( 1, 1 ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = CONE + C2 = CONE + ELSE +C +C One step of incremental condition estimation. +C + CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, A( 1, I ), + $ A( I, I ), SMINPR, S1, C1 ) + CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, A( 1, I ), + $ A( I, I ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Continue factorization, as rank is at least RANK. +C + IF( I.LT.N ) THEN +C +C Apply H(i)' to A(i:m,i+1:n) from the left. +C + AII = A( I, I ) + A( I, I ) = CONE + CALL ZLARF( 'Left', M-I+1, N-I, A( I, I ), 1, + $ DCONJG( TAU( I ) ), A( I, I+1 ), LDA, + $ ZWORK( 2*N+1 ) ) + A( I, I ) = AII + END IF +C +C Update partial column norms. +C + DO 30 J = I + 1, N + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( I, J ) ) / DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( N+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + IF( M-I.GT.0 ) THEN + DWORK( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) + DWORK( N+J ) = DWORK( J ) + ELSE + DWORK( J ) = ZERO + DWORK( N+J ) = ZERO + END IF + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + DO 40 I = 1, RANK + ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) + ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) + 40 CONTINUE +C + ZWORK( ISMIN+RANK ) = C1 + ZWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (RANK+1)-th column and set SVAL. +C + IF ( RANK.LT.N ) THEN + IF ( I.LT.M ) THEN + CALL ZSCAL( M-I, -A( I, I )*TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = AII + END IF + END IF + IF ( RANK.EQ.0 ) THEN + SMIN = ZERO + SMINPR = ZERO + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB3OYZ *** + END diff --git a/mex/sources/libslicot/MB3PYZ.f b/mex/sources/libslicot/MB3PYZ.f new file mode 100644 index 000000000..119bca081 --- /dev/null +++ b/mex/sources/libslicot/MB3PYZ.f @@ -0,0 +1,398 @@ + SUBROUTINE MB3PYZ( M, N, A, LDA, RCOND, SVLMAX, RANK, SVAL, JPVT, + $ TAU, DWORK, ZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a rank-revealing RQ factorization of a complex general +C M-by-N matrix A, which may be rank-deficient, and estimate its +C effective rank using incremental condition estimation. +C +C The routine uses a truncated RQ factorization with row pivoting: +C [ R11 R12 ] +C P * A = R * Q, where R = [ ], +C [ 0 R22 ] +C with R22 defined as the largest trailing upper triangular +C submatrix whose estimated condition number is less than 1/RCOND. +C The order of R22, RANK, is the effective rank of A. Condition +C estimation is performed during the RQ factorization process. +C Matrix R11 is full (but of small norm), or empty. +C +C MB3PYZ does not perform any scaling of the matrix A. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C A (input/output) COMPLEX*16 array, dimension ( LDA, N ) +C On entry, the leading M-by-N part of this array must +C contain the given matrix A. +C On exit, the upper triangle of the subarray +C A(M-RANK+1:M,N-RANK+1:N) contains the RANK-by-RANK upper +C triangular matrix R22; the remaining elements in the last +C RANK rows, with the array TAU, represent the unitary +C matrix Q as a product of RANK elementary reflectors +C (see METHOD). The first M-RANK rows contain the result +C of the RQ factorization process used. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,M). +C +C RCOND (input) DOUBLE PRECISION +C RCOND is used to determine the effective rank of A, which +C is defined as the order of the largest trailing triangular +C submatrix R22 in the RQ factorization with pivoting of A, +C whose estimated condition number is less than 1/RCOND. +C 0 <= RCOND <= 1. +C NOTE that when SVLMAX > 0, the estimated rank could be +C less than that defined above (see SVLMAX). +C +C SVLMAX (input) DOUBLE PRECISION +C If A is a submatrix of another matrix B, and the rank +C decision should be related to that matrix, then SVLMAX +C should be an estimate of the largest singular value of B +C (for instance, the Frobenius norm of B). If this is not +C the case, the input value SVLMAX = 0 should work. +C SVLMAX >= 0. +C +C RANK (output) INTEGER +C The effective (estimated) rank of A, i.e., the order of +C the submatrix R22. +C +C SVAL (output) DOUBLE PRECISION array, dimension ( 3 ) +C The estimates of some of the singular values of the +C triangular factor R: +C SVAL(1): largest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(2): smallest singular value of +C R(M-RANK+1:M,N-RANK+1:N); +C SVAL(3): smallest singular value of R(M-RANK:M,N-RANK:N), +C if RANK < MIN( M, N ), or of +C R(M-RANK+1:M,N-RANK+1:N), otherwise. +C If the triangular factorization is a rank-revealing one +C (which will be the case if the trailing rows were well- +C conditioned), then SVAL(1) will also be an estimate for +C the largest singular value of A, and SVAL(2) and SVAL(3) +C will be estimates for the RANK-th and (RANK+1)-st singular +C values of A, respectively. +C By examining these values, one can confirm that the rank +C is well defined with respect to the chosen value of RCOND. +C The ratio SVAL(1)/SVAL(2) is an estimate of the condition +C number of R(M-RANK+1:M,N-RANK+1:N). +C +C JPVT (output) INTEGER array, dimension ( M ) +C If JPVT(i) = k, then the i-th row of P*A was the k-th row +C of A. +C +C TAU (output) COMPLEX*16 array, dimension ( MIN( M, N ) ) +C The trailing RANK elements of TAU contain the scalar +C factors of the elementary reflectors. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension ( 2*M ) +C +C ZWORK COMPLEX*16 array, dimension ( 3*M-1 ) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated RQ factorization with row +C pivoting of A, P * A = R * Q, with R defined above, and, +C during this process, finds the largest trailing submatrix whose +C estimated condition number is less than 1/RCOND, taking the +C possible positive value of SVLMAX into account. This is performed +C using an adaptation of the LAPACK incremental condition estimation +C scheme and a slightly modified rank decision test. The +C factorization process stops when RANK has been determined. +C +C The matrix Q is represented as a product of elementary reflectors +C +C Q = H(k-rank+1)' H(k-rank+2)' . . . H(k)', where k = min(m,n). +C +C Each H(i) has the form +C +C H = I - tau * v * v' +C +C where tau is a complex scalar, and v is a complex vector with +C v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored +C on exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +C +C The matrix P is represented in jpvt as follows: If +C jpvt(j) = i +C then the jth row of P is the ith canonical unit vector. +C +C REFERENCES +C +C [1] Bischof, C.H. and P. Tang. +C Generalizing Incremental Condition Estimation. +C LAPACK Working Notes 32, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-132, +C May 1991. +C +C [2] Bischof, C.H. and P. Tang. +C Robust Incremental Condition Estimation. +C LAPACK Working Notes 33, Mathematics and Computer Science +C Division, Argonne National Laboratory, UT, CS-91-133, +C May 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue problem, matrix operations, unitary transformation, +C singular values. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ZERO, ONE, P05 + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, P05 = 0.05D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, RANK + DOUBLE PRECISION RCOND, SVLMAX +C .. Array Arguments .. + INTEGER JPVT( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), ZWORK( * ) + DOUBLE PRECISION DWORK( * ), SVAL( 3 ) +C .. Local Scalars .. + INTEGER I, ISMAX, ISMIN, ITEMP, J, JWORK, K, MKI, NKI, + $ PVT + COMPLEX*16 AII, C1, C2, S1, S2 + DOUBLE PRECISION SMAX, SMAXPR, SMIN, SMINPR, TEMP, TEMP2 +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZLACGV, ZLAIC1, ZLARF, ZLARFG, + $ ZSCAL, ZSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF( RCOND.LT.ZERO .OR. RCOND.GT.ONE ) THEN + INFO = -5 + ELSE IF( SVLMAX.LT.ZERO ) THEN + INFO = -6 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MB3PYZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + K = MIN( M, N ) + IF( K.EQ.0 ) THEN + RANK = 0 + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF +C + ISMIN = 1 + ISMAX = ISMIN + M + JWORK = ISMAX + M +C +C Initialize partial row norms and pivoting vector. The first m +C elements of DWORK store the exact row norms. +C + DO 10 I = 1, M + DWORK( I ) = DZNRM2( N, A( I, 1 ), LDA ) + DWORK( M+I ) = DWORK( I ) + JPVT( I ) = I + 10 CONTINUE +C +C Compute factorization and determine RANK using incremental +C condition estimation. +C + RANK = 0 +C + 20 CONTINUE + IF( RANK.LT.K ) THEN + I = K - RANK +C +C Determine ith pivot row and swap if necessary. +C + MKI = M - RANK + NKI = N - RANK + PVT = IDAMAX( MKI, DWORK, 1 ) +C + IF( PVT.NE.MKI ) THEN + CALL ZSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( MKI ) + JPVT( MKI ) = ITEMP + DWORK( PVT ) = DWORK( MKI ) + DWORK( M+PVT ) = DWORK( M+MKI ) + END IF +C + IF( NKI.GT.1 ) THEN +C +C Save A(m-k+i,n-k+i) and generate elementary reflector H(i) +C to annihilate A(m-k+i,1:n-k+i-1), k = min(m,n). +C A(m-k+i,1:n-k+i) * H(tau,v) = [0 , *] <=> +C H(conj(tau),v) A(m-k+i,1:n-k+i)^H = [0 ; *], +C using H(tau,v)^H = H(conj(tau),v). +C + CALL ZLACGV( NKI, A( MKI, 1 ), LDA ) + AII = A( MKI, NKI ) + CALL ZLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I ) + $ ) + END IF +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( A( M, N ) ) + IF ( SMAX.EQ.ZERO ) THEN + SVAL( 1 ) = ZERO + SVAL( 2 ) = ZERO + SVAL( 3 ) = ZERO + RETURN + END IF + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = CONE + C2 = CONE + ELSE +C +C One step of incremental condition estimation. +C + CALL ZCOPY ( RANK, A( MKI, NKI+1 ), LDA, ZWORK( JWORK ), 1 ) + CALL ZLAIC1( IMIN, RANK, ZWORK( ISMIN ), SMIN, + $ ZWORK( JWORK ), A( MKI, NKI ), SMINPR, S1, C1 ) + CALL ZLAIC1( IMAX, RANK, ZWORK( ISMAX ), SMAX, + $ ZWORK( JWORK ), A( MKI, NKI ), SMAXPR, S2, C2 ) + END IF +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C + IF( MKI.GT.1 ) THEN +C +C Continue factorization, as rank is at least RANK. +C Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right. +C + AII = A( MKI, NKI ) + A( MKI, NKI ) = CONE + CALL ZLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA, + $ TAU( I ), A, LDA, ZWORK( JWORK ) ) + A( MKI, NKI ) = AII +C +C Update partial row norms. +C + DO 30 J = 1, MKI - 1 + IF( DWORK( J ).NE.ZERO ) THEN + TEMP = ONE - + $ ( ABS( A( J, NKI ) )/DWORK( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = ONE + P05*TEMP* + $ ( DWORK( J ) / DWORK( M+J ) )**2 + IF( TEMP2.EQ.ONE ) THEN + DWORK( J ) = DZNRM2( NKI-1, A( J, 1 ), + $ LDA ) + DWORK( M+J ) = DWORK( J ) + ELSE + DWORK( J ) = DWORK( J )*SQRT( TEMP ) + END IF + END IF + 30 CONTINUE +C + END IF +C + DO 40 I = 1, RANK + ZWORK( ISMIN+I-1 ) = S1*ZWORK( ISMIN+I-1 ) + ZWORK( ISMAX+I-1 ) = S2*ZWORK( ISMAX+I-1 ) + 40 CONTINUE +C + ZWORK( ISMIN+RANK ) = C1 + ZWORK( ISMAX+RANK ) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) + GO TO 20 + END IF + END IF + END IF + END IF +C +C Restore the changed part of the (M-RANK)-th row and set SVAL. +C + IF ( RANK.LT.K .AND. NKI.GT.1 ) THEN + CALL ZLACGV( NKI-1, A( MKI, 1 ), LDA ) + CALL ZSCAL( NKI-1, -A( MKI, NKI )*TAU( I ), A( MKI, 1 ), LDA ) + A( MKI, NKI ) = AII + END IF + SVAL( 1 ) = SMAX + SVAL( 2 ) = SMIN + SVAL( 3 ) = SMINPR +C + RETURN +C *** Last line of MB3PYZ *** + END diff --git a/mex/sources/libslicot/MC01MD.f b/mex/sources/libslicot/MC01MD.f new file mode 100644 index 000000000..9da419a93 --- /dev/null +++ b/mex/sources/libslicot/MC01MD.f @@ -0,0 +1,162 @@ + SUBROUTINE MC01MD( DP, ALPHA, K, P, Q, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate, for a given real polynomial P(x) and a real scalar +C alpha, the leading K coefficients of the shifted polynomial +C K-1 +C P(x) = q(1) + q(2) * (x-alpha) + ... + q(K) * (x-alpha) + ... +C +C using Horner's algorithm. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP (input) INTEGER +C The degree of the polynomial P(x). DP >= 0. +C +C ALPHA (input) DOUBLE PRECISION +C The scalar value alpha of the problem. +C +C K (input) INTEGER +C The number of coefficients of the shifted polynomial to be +C computed. 1 <= K <= DP+1. +C +C P (input) DOUBLE PRECISION array, dimension (DP+1) +C This array must contain the coefficients of P(x) in +C increasing powers of x. +C +C Q (output) DOUBLE PRECISION array, dimension (DP+1) +C The leading K elements of this array contain the first +C K coefficients of the shifted polynomial in increasing +C powers of (x - alpha), and the next (DP-K+1) elements +C are used as internal workspace. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given the real polynomial +C 2 DP +C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , +C +C the routine computes the leading K coefficients of the shifted +C polynomial +C K-1 +C P(x) = q(1) + q(2) * (x - alpha) + ... + q(K) * (x - alpha) +C +C as follows. +C +C Applying Horner's algorithm (see [1]) to P(x), i.e. dividing P(x) +C by (x-alpha), yields +C +C P(x) = q(1) + (x-alpha) * D(x), +C +C where q(1) is the value of the constant term of the shifted +C polynomial and D(x) is the quotient polynomial of degree (DP-1) +C given by +C 2 DP-1 +C D(x) = d(2) + d(3) * x + d(4) * x + ... + d(DP+1) * x . +C +C Applying Horner's algorithm to D(x) and subsequent quotient +C polynomials yields q(2) and q(3), q(4), ..., q(K) respectively. +C +C It follows immediately that q(1) = P(alpha), and in general +C (i-1) +C q(i) = P (alpha) / (i - 1)! for i = 1, 2, ..., K. +C +C REFERENCES +C +C [1] STOER, J. and BULIRSCH, R. +C Introduction to Numerical Analysis. +C Springer-Verlag. 1980. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01AD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO, K + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION P(*), Q(*) +C .. Local Scalars .. + INTEGER I, J +C .. External Subroutines .. + EXTERNAL DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( DP.LT.0 ) THEN + INFO = -1 + ELSE IF( K.LE.0 .OR. K.GT.DP+1 ) THEN + INFO = -3 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC01MD', -INFO ) + RETURN + END IF +C + CALL DCOPY( DP+1, P, 1, Q, 1 ) + IF ( DP.EQ.0 .OR. ALPHA.EQ.ZERO ) + $ RETURN +C + DO 40 J = 1, K +C + DO 20 I = DP, J, -1 + Q(I) = Q(I) + ALPHA*Q(I+1) + 20 CONTINUE +C + 40 CONTINUE +C + RETURN +C *** Last line of MC01MD *** + END diff --git a/mex/sources/libslicot/MC01ND.f b/mex/sources/libslicot/MC01ND.f new file mode 100644 index 000000000..b45913fe7 --- /dev/null +++ b/mex/sources/libslicot/MC01ND.f @@ -0,0 +1,146 @@ + SUBROUTINE MC01ND( DP, XR, XI, P, VR, VI, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the value of the real polynomial P(x) at a given +C complex point x = x0 using Horner's algorithm. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP (input) INTEGER +C The degree of the polynomial P(x). DP >= 0. +C +C XR (input) DOUBLE PRECISION +C XI (input) DOUBLE PRECISION +C The real and imaginary parts, respectively, of x0. +C +C P (input) DOUBLE PRECISION array, dimension (DP+1) +C This array must contain the coefficients of the polynomial +C P(x) in increasing powers of x. +C +C VR (output) DOUBLE PRECISION +C VI (output) DOUBLE PRECISION +C The real and imaginary parts, respectively, of P(x0). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given the real polynomial +C 2 DP +C P(x) = p(1) + p(2) * x + p(3) * x + ... + p(DP+1) * x , +C +C the routine computes the value of P(x0) using the recursion +C +C q(DP+1) = p(DP+1), +C q(i) = x0*q(i+1) + p(i) for i = DP, DP-1, ..., 1, +C +C which is known as Horner's algorithm (see [1]). Then q(1) = P(x0). +C +C REFERENCES +C +C [1] STOER, J and BULIRSCH, R. +C Introduction to Numerical Analysis. +C Springer-Verlag. 1980. +C +C NUMERICAL ASPECTS +C +C The algorithm requires DP operations for real arguments and 4*DP +C for complex arguments. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01BD by Serge Steer. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO + DOUBLE PRECISION VI, VR, XI, XR +C .. Array Arguments .. + DOUBLE PRECISION P(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION T +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( DP.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01ND', -INFO ) + RETURN + END IF +C + INFO = 0 + VR = P(DP+1) + VI = ZERO +C + IF ( DP.EQ.0 ) + $ RETURN +C + IF ( XI.EQ.ZERO ) THEN +C +C X real. +C + DO 20 I = DP, 1, -1 + VR = VR*XR + P(I) + 20 CONTINUE +C + ELSE +C +C X complex. +C + DO 40 I = DP, 1, -1 + T = VR*XR - VI*XI + P(I) + VI = VI*XR + VR*XI + VR = T + 40 CONTINUE +C + END IF +C + RETURN +C *** Last line of MC01ND *** + END diff --git a/mex/sources/libslicot/MC01OD.f b/mex/sources/libslicot/MC01OD.f new file mode 100644 index 000000000..2d148791f --- /dev/null +++ b/mex/sources/libslicot/MC01OD.f @@ -0,0 +1,147 @@ + SUBROUTINE MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of a complex polynomial P(x) from its +C zeros. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of zeros (and hence the degree) of P(x). +C K >= 0. +C +C REZ (input) DOUBLE PRECISION array, dimension (K) +C IMZ (input) DOUBLE PRECISION array, dimension (K) +C The real and imaginary parts of the i-th zero of P(x) +C must be stored in REZ(i) and IMZ(i), respectively, where +C i = 1, 2, ..., K. The zeros may be supplied in any order. +C +C REP (output) DOUBLE PRECISION array, dimension (K+1) +C IMP (output) DOUBLE PRECISION array, dimension (K+1) +C These arrays contain the real and imaginary parts, +C respectively, of the coefficients of P(x) in increasing +C powers of x. If K = 0, then REP(1) is set to one and +C IMP(1) is set to zero. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*K+2) +C If K = 0, this array is not referenced. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes the coefficients of the complex K-th degree +C polynomial P(x) as +C +C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) +C +C where r(i) = (REZ(i),IMZ(i)), using real arithmetic. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01CD by Alan Brown and +C A.J. Geurts. +C +C REVISIONS +C +C V. Sima, May 2002. +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, K +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), IMP(*), IMZ(*), REP(*), REZ(*) +C .. Local Scalars .. + INTEGER I, K2 + DOUBLE PRECISION U, V +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( K.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + INFO = 0 + REP(1) = ONE + IMP(1) = ZERO + IF ( K.EQ.0 ) + $ RETURN +C + K2 = K + 2 +C + DO 20 I = 1, K + U = REZ(I) + V = IMZ(I) + DWORK(1) = ZERO + DWORK(K2) = ZERO + CALL DCOPY( I, REP, 1, DWORK(2), 1 ) + CALL DCOPY( I, IMP, 1, DWORK(K2+1), 1 ) +C + IF ( U.NE.ZERO ) THEN + CALL DAXPY( I, -U, REP, 1, DWORK, 1 ) + CALL DAXPY( I, -U, IMP, 1, DWORK(K2), 1 ) + END IF +C + IF ( V.NE.ZERO ) THEN + CALL DAXPY( I, V, IMP, 1, DWORK, 1 ) + CALL DAXPY( I, -V, REP, 1, DWORK(K2), 1 ) + END IF +C + CALL DCOPY( I+1, DWORK, 1, REP, 1 ) + CALL DCOPY( I+1, DWORK(K2), 1, IMP, 1 ) + 20 CONTINUE +C + RETURN +C *** Last line of MC01OD *** + END diff --git a/mex/sources/libslicot/MC01PD.f b/mex/sources/libslicot/MC01PD.f new file mode 100644 index 000000000..f378a84bd --- /dev/null +++ b/mex/sources/libslicot/MC01PD.f @@ -0,0 +1,159 @@ + SUBROUTINE MC01PD( K, REZ, IMZ, P, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of a real polynomial P(x) from its +C zeros. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of zeros (and hence the degree) of P(x). +C K >= 0. +C +C REZ (input) DOUBLE PRECISION array, dimension (K) +C IMZ (input) DOUBLE PRECISION array, dimension (K) +C The real and imaginary parts of the i-th zero of P(x) +C must be stored in REZ(i) and IMZ(i), respectively, where +C i = 1, 2, ..., K. The zeros may be supplied in any order, +C except that complex conjugate zeros must appear +C consecutively. +C +C P (output) DOUBLE PRECISION array, dimension (K+1) +C This array contains the coefficients of P(x) in increasing +C powers of x. If K = 0, then P(1) is set to one. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (K+1) +C If K = 0, this array is not referenced. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, (REZ(i),IMZ(i)) is a complex zero but +C (REZ(i-1),IMZ(i-1)) is not its conjugate. +C +C METHOD +C +C The routine computes the coefficients of the real K-th degree +C polynomial P(x) as +C +C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) +C +C where r(i) = (REZ(i),IMZ(i)). +C +C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) +C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 +C if r(i) is real. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01DD by A.J. Geurts. +C +C REVISIONS +C +C V. Sima, May 2002. +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, K +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION U, V +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( K.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + INFO = 0 + P(1) = ONE + IF ( K.EQ.0 ) + $ RETURN +C + I = 1 +C WHILE ( I <= K ) DO + 20 IF ( I.LE.K ) THEN + U = REZ(I) + V = IMZ(I) + DWORK(1) = ZERO +C + IF ( V.EQ.ZERO ) THEN + CALL DCOPY( I, P, 1, DWORK(2), 1 ) + CALL DAXPY( I, -U, P, 1, DWORK, 1 ) + I = I + 1 +C + ELSE + IF ( I.EQ.K ) THEN + INFO = K + RETURN + ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN + INFO = I + 1 + RETURN + END IF +C + DWORK(2) = ZERO + CALL DCOPY( I, P, 1, DWORK(3), 1 ) + CALL DAXPY( I, -(U + U), P, 1, DWORK(2), 1 ) + CALL DAXPY( I, U**2+V**2, P, 1, DWORK, 1 ) + I = I + 2 + END IF +C + CALL DCOPY( I, DWORK, 1, P, 1 ) + GO TO 20 + END IF +C END WHILE 20 +C + RETURN +C *** Last line of MC01PD *** + END diff --git a/mex/sources/libslicot/MC01PY.f b/mex/sources/libslicot/MC01PY.f new file mode 100644 index 000000000..d43f9b172 --- /dev/null +++ b/mex/sources/libslicot/MC01PY.f @@ -0,0 +1,157 @@ + SUBROUTINE MC01PY( K, REZ, IMZ, P, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of a real polynomial P(x) from its +C zeros. The coefficients are stored in decreasing order of the +C powers of x. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C K (input) INTEGER +C The number of zeros (and hence the degree) of P(x). +C K >= 0. +C +C REZ (input) DOUBLE PRECISION array, dimension (K) +C IMZ (input) DOUBLE PRECISION array, dimension (K) +C The real and imaginary parts of the i-th zero of P(x) +C must be stored in REZ(i) and IMZ(i), respectively, where +C i = 1, 2, ..., K. The zeros may be supplied in any order, +C except that complex conjugate zeros must appear +C consecutively. +C +C P (output) DOUBLE PRECISION array, dimension (K+1) +C This array contains the coefficients of P(x) in decreasing +C powers of x. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (K) +C If K = 0, this array is not referenced. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, (REZ(i),IMZ(i)) is a complex zero but +C (REZ(i-1),IMZ(i-1)) is not its conjugate. +C +C METHOD +C +C The routine computes the coefficients of the real K-th degree +C polynomial P(x) as +C +C P(x) = (x - r(1)) * (x - r(2)) * ... * (x - r(K)) +C +C where r(i) = (REZ(i),IMZ(i)). +C +C Note that REZ(i) = REZ(j) and IMZ(i) = -IMZ(j) if r(i) and r(j) +C form a complex conjugate pair (where i <> j), and that IMZ(i) = 0 +C if r(i) is real. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, K +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), IMZ(*), P(*), REZ(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION U, V +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( K.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01PY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + INFO = 0 + P(1) = ONE + IF ( K.EQ.0 ) + $ RETURN +C + I = 1 +C WHILE ( I <= K ) DO + 20 IF ( I.LE.K ) THEN + U = REZ(I) + V = IMZ(I) + DWORK(I) = ZERO +C + IF ( V.EQ.ZERO ) THEN + CALL DAXPY( I, -U, P, 1, DWORK, 1 ) +C + ELSE + IF ( I.EQ.K ) THEN + INFO = K + RETURN + ELSE IF ( ( U.NE.REZ(I+1) ) .OR. ( V.NE.-IMZ(I+1) ) ) THEN + INFO = I + 1 + RETURN + END IF +C + DWORK(I+1) = ZERO + CALL DAXPY( I, -(U + U), P, 1, DWORK, 1 ) + CALL DAXPY( I, U**2+V**2, P, 1, DWORK(2), 1 ) + I = I + 1 + END IF +C + CALL DCOPY( I, DWORK, 1, P(2), 1 ) + I = I + 1 + GO TO 20 + END IF +C END WHILE 20 +C + RETURN +C *** Last line of MC01PY *** + END diff --git a/mex/sources/libslicot/MC01QD.f b/mex/sources/libslicot/MC01QD.f new file mode 100644 index 000000000..652887bb6 --- /dev/null +++ b/mex/sources/libslicot/MC01QD.f @@ -0,0 +1,207 @@ + SUBROUTINE MC01QD( DA, DB, A, B, RQ, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for two given real polynomials A(x) and B(x), the +C quotient polynomial Q(x) and the remainder polynomial R(x) of +C A(x) divided by B(x). +C +C The polynomials Q(x) and R(x) satisfy the relationship +C +C A(x) = B(x) * Q(x) + R(x), +C +C where the degree of R(x) is less than the degree of B(x). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the numerator polynomial A(x). DA >= -1. +C +C DB (input/output) INTEGER +C On entry, the degree of the denominator polynomial B(x). +C DB >= 0. +C On exit, if B(DB+1) = 0.0 on entry, then DB contains the +C index of the highest power of x for which B(DB+1) <> 0.0. +C +C A (input) DOUBLE PRECISION array, dimension (DA+1) +C This array must contain the coefficients of the +C numerator polynomial A(x) in increasing powers of x +C unless DA = -1 on entry, in which case A(x) is taken +C to be the zero polynomial. +C +C B (input) DOUBLE PRECISION array, dimension (DB+1) +C This array must contain the coefficients of the +C denominator polynomial B(x) in increasing powers of x. +C +C RQ (output) DOUBLE PRECISION array, dimension (DA+1) +C If DA < DB on exit, then this array contains the +C coefficients of the remainder polynomial R(x) in +C increasing powers of x; Q(x) is the zero polynomial. +C Otherwise, the leading DB elements of this array contain +C the coefficients of R(x) in increasing powers of x, and +C the next (DA-DB+1) elements contain the coefficients of +C Q(x) in increasing powers of x. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = k: if the degree of the denominator polynomial B(x) has +C been reduced to (DB - k) because B(DB+1-j) = 0.0 on +C entry for j = 0, 1, ..., k-1 and B(DB+1-k) <> 0.0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if on entry, DB >= 0 and B(i) = 0.0, where +C i = 1, 2, ..., DB+1. +C +C METHOD +C +C Given real polynomials +C DA +C A(x) = a(1) + a(2) * x + ... + a(DA+1) * x +C +C and +C DB +C B(x) = b(1) + b(2) * x + ... + b(DB+1) * x +C +C where b(DB+1) is non-zero, the routine computes the coeffcients of +C the quotient polynomial +C DA-DB +C Q(x) = q(1) + q(2) * x + ... + q(DA-DB+1) * x +C +C and the remainder polynomial +C DB-1 +C R(x) = r(1) + r(2) * x + ... + r(DB) * x +C +C such that A(x) = B(x) * Q(x) + R(x). +C +C The algorithm used is synthetic division of polynomials (see [1]), +C which involves the following steps: +C +C (a) compute q(k+1) = a(DB+k+1) / b(DB+1) +C +C and +C +C (b) set a(j) = a(j) - q(k+1) * b(j-k) for j = k+1, ..., DB+k. +C +C Steps (a) and (b) are performed for k = DA-DB, DA-DB-1, ..., 0 and +C the algorithm terminates with r(i) = a(i) for i = 1, 2, ..., DB. +C +C REFERENCES +C +C [1] Knuth, D.E. +C The Art of Computer Programming, (Vol. 2, Seminumerical +C Algorithms). +C Addison-Wesley, Reading, Massachusetts (2nd Edition), 1981. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01ED by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DA, DB, INFO, IWARN +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*), RQ(*) +C .. Local Scalars .. + INTEGER N + DOUBLE PRECISION Q +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IWARN = 0 + INFO = 0 + IF( DA.LT.-1 ) THEN + INFO = -1 + ELSE IF( DB.LT.0 ) THEN + INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC01QD', -INFO ) + RETURN + END IF +C +C WHILE ( DB >= 0 and B(DB+1) = 0 ) DO + 20 IF ( DB.GE.0 ) THEN + IF ( B(DB+1).EQ.ZERO ) THEN + DB = DB - 1 + IWARN = IWARN + 1 + GO TO 20 + END IF + END IF +C END WHILE 20 + IF ( DB.EQ.-1 ) THEN + INFO = 1 + RETURN + END IF +C +C B(x) is non-zero. +C + IF ( DA.GE.0 ) THEN + N = DA + CALL DCOPY( N+1, A, 1, RQ, 1 ) +C WHILE ( N >= DB ) DO + 40 IF ( N.GE.DB ) THEN + IF ( RQ(N+1).NE.ZERO ) THEN + Q = RQ(N+1)/B(DB+1) + CALL DAXPY( DB, -Q, B, 1, RQ(N-DB+1), 1 ) + RQ(N+1) = Q + END IF + N = N - 1 + GO TO 40 + END IF +C END WHILE 40 + END IF +C + RETURN +C *** Last line of MC01QD *** + END diff --git a/mex/sources/libslicot/MC01RD.f b/mex/sources/libslicot/MC01RD.f new file mode 100644 index 000000000..da1b3dc2f --- /dev/null +++ b/mex/sources/libslicot/MC01RD.f @@ -0,0 +1,299 @@ + SUBROUTINE MC01RD( DP1, DP2, DP3, ALPHA, P1, P2, P3, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of the polynomial +C +C P(x) = P1(x) * P2(x) + alpha * P3(x), +C +C where P1(x), P2(x) and P3(x) are given real polynomials and alpha +C is a real scalar. +C +C Each of the polynomials P1(x), P2(x) and P3(x) may be the zero +C polynomial. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP1 (input) INTEGER +C The degree of the polynomial P1(x). DP1 >= -1. +C +C DP2 (input) INTEGER +C The degree of the polynomial P2(x). DP2 >= -1. +C +C DP3 (input/output) INTEGER +C On entry, the degree of the polynomial P3(x). DP3 >= -1. +C On exit, the degree of the polynomial P(x). +C +C ALPHA (input) DOUBLE PRECISION +C The scalar value alpha of the problem. +C +C P1 (input) DOUBLE PRECISION array, dimension (lenp1) +C where lenp1 = DP1 + 1 if DP1 >= 0 and 1 otherwise. +C If DP1 >= 0, then this array must contain the +C coefficients of P1(x) in increasing powers of x. +C If DP1 = -1, then P1(x) is taken to be the zero +C polynomial, P1 is not referenced and can be supplied +C as a dummy array. +C +C P2 (input) DOUBLE PRECISION array, dimension (lenp2) +C where lenp2 = DP2 + 1 if DP2 >= 0 and 1 otherwise. +C If DP2 >= 0, then this array must contain the +C coefficients of P2(x) in increasing powers of x. +C If DP2 = -1, then P2(x) is taken to be the zero +C polynomial, P2 is not referenced and can be supplied +C as a dummy array. +C +C P3 (input/output) DOUBLE PRECISION array, dimension (lenp3) +C where lenp3 = MAX(DP1+DP2,DP3,0) + 1. +C On entry, if DP3 >= 0, then this array must contain the +C coefficients of P3(x) in increasing powers of x. +C On entry, if DP3 = -1, then P3(x) is taken to be the zero +C polynomial. +C On exit, the leading (DP3+1) elements of this array +C contain the coefficients of P(x) in increasing powers of x +C unless DP3 = -1 on exit, in which case the coefficients of +C P(x) (the zero polynomial) are not stored in the array. +C This is the case, for instance, when ALPHA = 0.0 and +C P1(x) or P2(x) is the zero polynomial. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given real polynomials +C +C DP1 i DP2 i +C P1(x) = SUM a(i+1) * x , P2(x) = SUM b(i+1) * x and +C i=0 i=0 +C +C DP3 i +C P3(x) = SUM c(i+1) * x , +C i=0 +C +C the routine computes the coefficents of P(x) = P1(x) * P2(x) + +C DP3 i +C alpha * P3(x) = SUM d(i+1) * x as follows. +C i=0 +C +C Let e(i) = c(i) for 1 <= i <= DP3+1 and e(i) = 0 for i > DP3+1. +C Then if DP1 >= DP2, +C +C i +C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = 1, ..., DP2+1, +C k=1 +C +C i +C d(i) = SUM a(k) * b(i-k+1) + f(i), for i = DP2+2, ..., DP1+1 +C k=i-DP2 +C +C and +C DP1+1 +C d(i) = SUM a(k) * b(i-k+1) + f(i) for i = DP1+2,...,DP1+DP2+1, +C k=i-DP2 +C +C where f(i) = alpha * e(i). +C +C Similar formulas hold for the case DP1 < DP2. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01FD by C. Klimann and +C A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP1, DP2, DP3, INFO + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION P1(*), P2(*), P3(*) +C .. Local Scalars .. + INTEGER D1, D2, D3, DMAX, DMIN, DSUM, E3, I, J, K, L +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( DP1.LT.-1 ) THEN + INFO = -1 + ELSE IF( DP2.LT.-1 ) THEN + INFO = -2 + ELSE IF( DP3.LT.-1 ) THEN + INFO = -3 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC01RD', -INFO ) + RETURN + END IF +C +C Computation of the exact degree of the polynomials, i.e., Di such +C that either Di = -1 or Pi(Di+1) is non-zero. +C + D1 = DP1 +C WHILE ( D1 >= 0 and P1(D1+1) = 0 ) DO + 20 IF ( D1.GE.0 ) THEN + IF ( P1(D1+1).EQ.ZERO ) THEN + D1 = D1 - 1 + GO TO 20 + END IF + END IF +C END WHILE 20 + D2 = DP2 +C WHILE ( D2 >= 0 and P2(D2+1) = 0 ) DO + 40 IF ( D2.GE.0 ) THEN + IF ( P2(D2+1).EQ.ZERO ) THEN + D2 = D2 - 1 + GO TO 40 + END IF + END IF +C END WHILE 40 + IF ( ALPHA.EQ.ZERO ) THEN + D3 = -1 + ELSE + D3 = DP3 + END IF +C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO + 60 IF ( D3.GE.0 ) THEN + IF ( P3(D3+1).EQ.ZERO ) THEN + D3 = D3 - 1 + GO TO 60 + END IF + END IF +C END WHILE 60 +C +C Computation of P3(x) := ALPHA * P3(x). +C + CALL DSCAL( D3+1, ALPHA, P3, 1 ) +C + IF ( ( D1.EQ.-1 ) .OR. ( D2.EQ.-1 ) ) THEN + DP3 = D3 + RETURN + END IF +C +C P1(x) and P2(x) are non-zero polynomials. +C + DSUM = D1 + D2 + DMAX = MAX( D1, D2 ) + DMIN = DSUM - DMAX +C + IF ( D3.LT.DSUM ) THEN + P3(D3+2) = ZERO + CALL DCOPY( DSUM-D3-1, P3(D3+2), 0, P3(D3+3), 1 ) + D3 = DSUM + END IF +C + IF ( ( D1.EQ.0 ) .OR. ( D2.EQ.0 ) ) THEN +C +C D1 or D2 is zero. +C + IF ( D1.NE.0 ) THEN + CALL DAXPY( D1+1, P2(1), P1, 1, P3, 1 ) + ELSE + CALL DAXPY( D2+1, P1(1), P2, 1, P3, 1 ) + END IF + ELSE +C +C D1 and D2 are both nonzero. +C +C First part of the computation. +C + DO 80 I = 1, DMIN + 1 + P3(I) = P3(I) + DDOT( I, P1, 1, P2, -1 ) + 80 CONTINUE +C +C Second part of the computation. +C + DO 100 I = DMIN + 2, DMAX + 1 + IF ( D1.GT.D2 ) THEN + K = I - D2 + P3(I) = P3(I) + DDOT( DMIN+1, P1(K), 1, P2, -1 ) + ELSE + K = I - D1 + P3(I) = P3(I) + DDOT( DMIN+1, P2(K), -1, P1, 1 ) + END IF + 100 CONTINUE +C +C Third part of the computation. +C + E3 = DSUM + 2 +C + DO 120 I = DMAX + 2, DSUM + 1 + J = E3 - I + K = I - DMIN + L = I - DMAX + IF ( D1.GT.D2 ) THEN + P3(I) = P3(I) + DDOT( J, P1(K), 1, P2(L), -1 ) + ELSE + P3(I) = P3(I) + DDOT( J, P1(L), -1, P2(K), 1 ) + END IF + 120 CONTINUE +C + END IF +C +C Computation of the exact degree of P3(x). +C +C WHILE ( D3 >= 0 and P3(D3+1) = 0 ) DO + 140 IF ( D3.GE.0 ) THEN + IF ( P3(D3+1).EQ.ZERO ) THEN + D3 = D3 - 1 + GO TO 140 + END IF + END IF +C END WHILE 140 + DP3 = D3 +C + RETURN +C *** Last line of MC01RD *** + END diff --git a/mex/sources/libslicot/MC01SD.f b/mex/sources/libslicot/MC01SD.f new file mode 100644 index 000000000..d84362ee2 --- /dev/null +++ b/mex/sources/libslicot/MC01SD.f @@ -0,0 +1,281 @@ + SUBROUTINE MC01SD( DP, P, S, T, MANT, E, IWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To scale the coefficients of the real polynomial P(x) such that +C the coefficients of the scaled polynomial Q(x) = sP(tx) have +C minimal variation, where s and t are real scalars. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP (input) INTEGER +C The degree of the polynomial P(x). DP >= 0. +C +C P (input/output) DOUBLE PRECISION array, dimension (DP+1) +C On entry, this array must contain the coefficients of P(x) +C in increasing powers of x. +C On exit, this array contains the coefficients of the +C scaled polynomial Q(x) in increasing powers of x. +C +C S (output) INTEGER +C The exponent of the floating-point representation of the +C scaling factor s = BASE**S, where BASE is the base of the +C machine representation of floating-point numbers (see +C LAPACK Library Routine DLAMCH). +C +C T (output) INTEGER +C The exponent of the floating-point representation of the +C scaling factor t = BASE**T. +C +C MANT (output) DOUBLE PRECISION array, dimension (DP+1) +C This array contains the mantissas of the standard +C floating-point representation of the coefficients of the +C scaled polynomial Q(x) in increasing powers of x. +C +C E (output) INTEGER array, dimension (DP+1) +C This array contains the exponents of the standard +C floating-point representation of the coefficients of the +C scaled polynomial Q(x) in increasing powers of x. +C +C Workspace +C +C IWORK INTEGER array, dimension (DP+1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if on entry, P(x) is the zero polynomial. +C +C METHOD +C +C Define the variation of the coefficients of the real polynomial +C +C 2 DP +C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x +C +C whose non-zero coefficients can be represented as +C e(i) +C p(i) = m(i) * BASE (where 1 <= ABS(m(i)) < BASE) +C +C by +C +C V = max(e(i)) - min(e(i)), +C +C where max and min are taken over the indices i for which p(i) is +C non-zero. +C DP i i +C For the scaled polynomial P(cx) = SUM p(i) * c * x with +C i=0 +C j +C c = (BASE) , the variation V(j) is given by +C +C V(j) = max(e(i) + j * i) - min(e(i) + j * i). +C +C Using the fact that V(j) is a convex function of j, the routine +C determines scaling factors s = (BASE)**S and t = (BASE)**T such +C that the coefficients of the scaled polynomial Q(x) = sP(tx) +C satisfy the following conditions: +C +C (a) 1 <= q(0) < BASE and +C +C (b) the variation of the coefficients of Q(x) is minimal. +C +C Further details can be found in [1]. +C +C REFERENCES +C +C [1] Dunaway, D.K. +C Calculation of Zeros of a Real Polynomial through +C Factorization using Euclid's Algorithm. +C SIAM J. Numer. Anal., 11, pp. 1087-1104, 1974. +C +C NUMERICAL ASPECTS +C +C Since the scaling is performed on the exponents of the floating- +C point representation of the coefficients of P(x), no rounding +C errors occur during the computation of the coefficients of Q(x). +C +C FURTHER COMMENTS +C +C The scaling factors s and t are BASE dependent. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01GD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO, S, T +C .. Array Arguments .. + INTEGER E(*), IWORK(*) + DOUBLE PRECISION MANT(*), P(*) +C .. Local Scalars .. + LOGICAL OVFLOW + INTEGER BETA, DV, I, INC, J, LB, M, UB, V0, V1 +C .. External Functions .. + INTEGER MC01SX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, MC01SX +C .. External Subroutines .. + EXTERNAL MC01SW, MC01SY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, NINT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF( DP.LT.0 ) THEN + INFO = -1 +C +C Error return. +C + CALL XERBLA( 'MC01SD', -INFO ) + RETURN + END IF +C + INFO = 0 + LB = 1 +C WHILE ( LB <= DP+1 and P(LB) = 0 ) DO + 20 IF ( LB.LE.DP+1 ) THEN + IF ( P(LB).EQ.ZERO ) THEN + LB = LB + 1 + GO TO 20 + END IF + END IF +C END WHILE 20 +C +C LB = MIN( i: P(i) non-zero). +C + IF ( LB.EQ.DP+2 ) THEN + INFO = 1 + RETURN + END IF +C + UB = DP + 1 +C WHILE ( P(UB) = 0 ) DO + 40 IF ( P(UB).EQ.ZERO ) THEN + UB = UB - 1 + GO TO 40 + END IF +C END WHILE 40 +C +C UB = MAX(i: P(i) non-zero). +C + BETA = DLAMCH( 'Base' ) +C + DO 60 I = 1, DP + 1 + CALL MC01SW( P(I), BETA, MANT(I), E(I) ) + 60 CONTINUE +C +C First prescaling. +C + M = E(LB) + IF ( M.NE.0 ) THEN +C + DO 80 I = LB, UB + IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M + 80 CONTINUE +C + END IF + S = -M +C +C Second prescaling. +C + IF ( UB.GT.1 ) M = NINT( DBLE( E(UB) )/DBLE( UB-1 ) ) +C + DO 100 I = LB, UB + IF ( MANT(I).NE.ZERO ) E(I) = E(I) - M*(I-1) + 100 CONTINUE +C + T = -M +C + V0 = MC01SX( LB, UB, E, MANT ) + J = 1 +C + DO 120 I = LB, UB + IF ( MANT(I).NE.ZERO ) IWORK(I) = E(I) + (I-1) + 120 CONTINUE +C + V1 = MC01SX( LB, UB, IWORK, MANT ) + DV = V1 - V0 + IF ( DV.NE.0 ) THEN + IF ( DV.GT.0 ) THEN + J = 0 + INC = -1 + V1 = V0 + DV = -DV +C + DO 130 I = LB, UB + IWORK(I) = E(I) + 130 CONTINUE +C + ELSE + INC = 1 + END IF +C WHILE ( DV < 0 ) DO + 140 IF ( DV.LT.0 ) THEN + V0 = V1 +C + DO 150 I = LB, UB + E(I) = IWORK(I) + 150 CONTINUE +C + J = J + INC +C + DO 160 I = LB, UB + IWORK(I) = E(I) + INC*(I-1 ) + 160 CONTINUE +C + V1 = MC01SX( LB, UB, IWORK, MANT ) + DV = V1 - V0 + GO TO 140 + END IF +C END WHILE 140 + T = T + J - INC + END IF +C +C Evaluation of the output parameters. +C + DO 180 I = LB, UB + CALL MC01SY( MANT(I), E(I), BETA, P(I), OVFLOW ) + 180 CONTINUE +C + RETURN +C *** Last line of MC01SD *** + END diff --git a/mex/sources/libslicot/MC01SW.f b/mex/sources/libslicot/MC01SW.f new file mode 100644 index 000000000..55e155e59 --- /dev/null +++ b/mex/sources/libslicot/MC01SW.f @@ -0,0 +1,104 @@ + SUBROUTINE MC01SW( A, B, M, E ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the mantissa M and the exponent E of a real number A such +C that +C A = M * B**E +C 1 <= ABS( M ) < B +C if A is non-zero. If A is zero, then M and E are set to 0. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input) DOUBLE PRECISION +C The number whose mantissa and exponent are required. +C +C B (input) INTEGER +C The base of the floating-point arithmetic. +C +C M (output) DOUBLE PRECISION +C The mantissa of the floating-point representation of A. +C +C E (output) INTEGER +C The exponent of the floating-point representation of A. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01GZ by A.J. Geurts. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER B, E + DOUBLE PRECISION A, M +C .. Local Scalars .. + DOUBLE PRECISION DB +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE +C .. Executable Statements .. +C +C Quick return if possible. +C + IF ( A.EQ.ZERO ) THEN + M = ZERO + E = 0 + RETURN + END IF +C +C A non-zero. +C + DB = DBLE( B ) + M = ABS( A ) + E = 0 +C WHILE ( M >= B ) DO + 20 IF ( M.GE.DB ) THEN + M = M/DB + E = E + 1 + GO TO 20 + END IF +C END WHILE 20 +C WHILE ( M < 1 ) DO + 40 IF ( M.LT.ONE ) THEN + M = M*DB + E = E - 1 + GO TO 40 + END IF +C END WHILE 40 +C + IF ( A.LT.ZERO ) M = -M +C + RETURN +C *** Last line of MC01SW *** + END diff --git a/mex/sources/libslicot/MC01SX.f b/mex/sources/libslicot/MC01SX.f new file mode 100644 index 000000000..c20360154 --- /dev/null +++ b/mex/sources/libslicot/MC01SX.f @@ -0,0 +1,68 @@ + INTEGER FUNCTION MC01SX( LB, UB, E, MANT ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the variation V of the exponents of a series of +C non-zero floating-point numbers: a(j) = MANT(j) * beta**(E(j)), +C where beta is the base of the machine representation of +C floating-point numbers, i.e., +C V = max(E(j)) - min(E(j)), j = LB,...,UB and MANT(j) non-zero. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01GX by A.J. Geurts. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER LB, UB +C .. Array Arguments .. + INTEGER E(*) + DOUBLE PRECISION MANT(*) +C .. Local Scalars .. + INTEGER J, MAXE, MINE +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + MAXE = E(LB) + MINE = MAXE +C + DO 20 J = LB + 1, UB + IF ( MANT(J).NE.ZERO ) THEN + MAXE = MAX( MAXE, E(J) ) + MINE = MIN( MINE, E(J) ) + END IF + 20 CONTINUE +C + MC01SX = MAXE - MINE +C + RETURN +C *** Last line of MC01SX *** + END diff --git a/mex/sources/libslicot/MC01SY.f b/mex/sources/libslicot/MC01SY.f new file mode 100644 index 000000000..ab187aa50 --- /dev/null +++ b/mex/sources/libslicot/MC01SY.f @@ -0,0 +1,146 @@ + SUBROUTINE MC01SY( M, E, B, A, OVFLOW ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a real number A from its mantissa M and its exponent E, +C i.e., +C A = M * B**E. +C M and E need not be the standard floating-point values. +C If ABS(A) < B**(EMIN-1), i.e. the smallest positive model number, +C then the routine returns A = 0. +C If M = 0, then the routine returns A = 0 regardless of the value +C of E. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) DOUBLE PRECISION +C The mantissa of the floating-point representation of A. +C +C E (input) INTEGER +C The exponent of the floating-point representation of A. +C +C B (input) INTEGER +C The base of the floating-point arithmetic. +C +C A (output) DOUBLE PRECISION +C The value of M * B**E. +C +C OVFLOW (output) LOGICAL +C The value .TRUE., if ABS(M) * B**E >= B**EMAX (where EMAX +C is the largest possible exponent) and .FALSE. otherwise. +C A is not defined if OVFLOW = .TRUE.. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01GY by A.J. Geurts. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL OVFLOW + INTEGER B, E + DOUBLE PRECISION A, M +C .. Local Scalars .. + INTEGER EMAX, EMIN, ET, EXPON + DOUBLE PRECISION BASE, MT +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. Intrinsic Functions .. + INTRINSIC ABS, MOD +C .. Executable Statements .. +C + OVFLOW = .FALSE. +C + IF ( ( M.EQ.ZERO ) .OR. ( E.EQ.0 ) ) THEN + A = M + RETURN + END IF +C +C Determination of the mantissa MT and the exponent ET of the +C standard floating-point representation. +C + EMIN = DLAMCH( 'Minimum exponent' ) + EMAX = DLAMCH( 'Largest exponent' ) + MT = M + ET = E +C WHILE ( ABS( MT ) >= B ) DO + 20 IF ( ABS( MT ).GE.B ) THEN + MT = MT/B + ET = ET + 1 + GO TO 20 + END IF +C END WHILE 20 +C WHILE ( ABS( MT ) < 1 ) DO + 40 IF ( ABS( MT ).LT.ONE ) THEN + MT = MT*B + ET = ET - 1 + GO TO 40 + END IF +C END WHILE 40 +C + IF ( ET.LT.EMIN ) THEN + A = ZERO + RETURN + END IF +C + IF ( ET.GE.EMAX ) THEN + OVFLOW = .TRUE. + RETURN + END IF +C +C Computation of the value of A by the relation +C M * B**E = A * (BASE)**EXPON +C + EXPON = ABS( ET ) + A = MT + BASE = B + IF ( ET.LT.0 ) BASE = ONE/BASE +C WHILE ( not EXPON = 0 ) DO + 60 IF ( EXPON.NE.0 ) THEN + IF ( MOD( EXPON, 2 ).EQ.0 ) THEN + BASE = BASE*BASE + EXPON = EXPON/2 + ELSE + A = A*BASE + EXPON = EXPON - 1 + END IF + GO TO 60 + END IF +C END WHILE 60 +C + RETURN +C *** Last line of MC01SY *** + END diff --git a/mex/sources/libslicot/MC01TD.f b/mex/sources/libslicot/MC01TD.f new file mode 100644 index 000000000..249f5c367 --- /dev/null +++ b/mex/sources/libslicot/MC01TD.f @@ -0,0 +1,305 @@ + SUBROUTINE MC01TD( DICO, DP, P, STABLE, NZ, DWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine whether or not a given polynomial P(x) with real +C coefficients is stable, either in the continuous-time or discrete- +C time case. +C +C A polynomial is said to be stable in the continuous-time case +C if all its zeros lie in the left half-plane, and stable in the +C discrete-time case if all its zeros lie inside the unit circle. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Indicates whether the stability test to be applied to +C P(x) is in the continuous-time or discrete-time case as +C follows: +C = 'C': Continuous-time case; +C = 'D': Discrete-time case. +C +C Input/Output Parameters +C +C DP (input/output) INTEGER +C On entry, the degree of the polynomial P(x). DP >= 0. +C On exit, if P(DP+1) = 0.0 on entry, then DP contains the +C index of the highest power of x for which P(DP+1) <> 0.0. +C +C P (input) DOUBLE PRECISION array, dimension (DP+1) +C This array must contain the coefficients of P(x) in +C increasing powers of x. +C +C STABLE (output) LOGICAL +C Contains the value .TRUE. if P(x) is stable and the value +C .FALSE. otherwise (see also NUMERICAL ASPECTS). +C +C NZ (output) INTEGER +C If INFO = 0, contains the number of unstable zeros - that +C is, the number of zeros of P(x) in the right half-plane if +C DICO = 'C' or the number of zeros of P(x) outside the unit +C circle if DICO = 'D' (see also NUMERICAL ASPECTS). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*DP+2) +C The leading (DP+1) elements of DWORK contain the Routh +C coefficients, if DICO = 'C', or the constant terms of +C the Schur-Cohn transforms, if DICO = 'D'. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = k: if the degree of the polynomial P(x) has been +C reduced to (DB - k) because P(DB+1-j) = 0.0 on entry +C for j = 0, 1,..., k-1 and P(DB+1-k) <> 0.0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if on entry, P(x) is the zero polynomial; +C = 2: if the polynomial P(x) is most probably unstable, +C although it may be stable with one or more zeros +C very close to either the imaginary axis if +C DICO = 'C' or the unit circle if DICO = 'D'. +C The number of unstable zeros (NZ) is not determined. +C +C METHOD +C +C The stability of the real polynomial +C 2 DP +C P(x) = p(0) + p(1) * x + p(2) * x + ... + p(DP) x +C +C is determined as follows. +C +C In the continuous-time case (DICO = 'C') the Routh algorithm +C (see [1]) is used. The routine computes the Routh coefficients and +C if they are non-zero then the number of sign changes in the +C sequence of the coefficients is equal to the number of zeros with +C positive imaginary part. +C +C In the discrete-time case (DICO = 'D') the Schur-Cohn +C algorithm (see [2] and [3]) is applied to the reciprocal +C polynomial +C 2 DP +C Q(x) = p(DP) + p(DP-1) * x + p(DP-2) * x + ... + p(0) x . +C +C The routine computes the constant terms of the Schur transforms +C and if all of them are non-zero then the number of zeros of P(x) +C with modulus greater than unity is obtained from the sequence of +C constant terms. +C +C REFERENCES +C +C [1] Gantmacher, F.R. +C Applications of the Theory of Matrices. +C Interscience Publishers, New York, 1959. +C +C [2] Kucera, V. +C Discrete Linear Control. The Algorithmic Approach. +C John Wiley & Sons, Chichester, 1979. +C +C [3] Henrici, P. +C Applied and Computational Complex Analysis (Vol. 1). +C John Wiley & Sons, New York, 1974. +C +C NUMERICAL ASPECTS +C +C The algorithm used by the routine is numerically stable. +C +C Note that if some of the Routh coefficients (DICO = 'C') or +C some of the constant terms of the Schur-Cohn transforms (DICO = +C 'D') are small relative to EPS (the machine precision), then +C the number of unstable zeros (and hence the value of STABLE) may +C be incorrect. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01HD by F. Delebecque and +C A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations, +C stability, stability criteria, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + LOGICAL STABLE + INTEGER DP, INFO, IWARN, NZ +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), P(*) +C .. Local Scalars .. + LOGICAL DICOC + INTEGER I, K, K1, K2, SIGNUM + DOUBLE PRECISION ALPHA, P1, PK1 +C .. External Functions .. + INTEGER IDAMAX + LOGICAL LSAME + EXTERNAL IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DRSCL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC SIGN +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + DICOC = LSAME( DICO, 'C' ) +C +C Test the input scalar arguments. +C + IF( .NOT.DICOC .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( DP.LT.0 ) THEN + INFO = -2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC01TD', -INFO ) + RETURN + END IF +C +C WHILE (DP >= 0 and P(DP+1) = 0 ) DO + 20 IF ( DP.GE.0 ) THEN + IF ( P(DP+1).EQ.ZERO ) THEN + DP = DP - 1 + IWARN = IWARN + 1 + GO TO 20 + END IF + END IF +C END WHILE 20 +C + IF ( DP.EQ.-1 ) THEN + INFO = 1 + RETURN + END IF +C +C P(x) is not the zero polynomial and its degree is exactly DP. +C + IF ( DICOC ) THEN +C +C Continuous-time case. +C +C Compute the Routh coefficients and the number of sign changes. +C + CALL DCOPY( DP+1, P, 1, DWORK, 1 ) + NZ = 0 + K = DP +C WHILE ( K > 0 and DWORK(K) non-zero) DO + 40 IF ( K.GT.0 ) THEN + IF ( DWORK(K).EQ.ZERO ) THEN + INFO = 2 + ELSE + ALPHA = DWORK(K+1)/DWORK(K) + IF ( ALPHA.LT.ZERO ) NZ = NZ + 1 + K = K - 1 +C + DO 60 I = K, 2, -2 + DWORK(I) = DWORK(I) - ALPHA*DWORK(I-1) + 60 CONTINUE +C + GO TO 40 + END IF + END IF +C END WHILE 40 + ELSE +C +C Discrete-time case. +C +C To apply [3], section 6.8, on the reciprocal of polynomial +C P(x) the elements of the array P are copied in DWORK in +C reverse order. +C + CALL DCOPY( DP+1, P, 1, DWORK, -1 ) +C K-1 +C DWORK(K),...,DWORK(DP+1), are the coefficients of T P(x) +C scaled with a factor alpha(K) in order to avoid over- or +C underflow, +C i-1 +C DWORK(i), i = 1,...,K, contains alpha(i) * T P(0). +C + SIGNUM = ONE + NZ = 0 + K = 1 +C WHILE ( K <= DP and DWORK(K) non-zero ) DO + 80 IF ( ( K.LE.DP ) .AND. ( INFO.EQ.0 ) ) THEN +C K +C Compute the coefficients of T P(x). +C + K1 = DP - K + 2 + K2 = DP + 2 + ALPHA = DWORK(K-1+IDAMAX( K1, DWORK(K), 1 )) + IF ( ALPHA.EQ.ZERO ) THEN + INFO = 2 + ELSE + CALL DCOPY( K1, DWORK(K), 1, DWORK(K2), 1 ) + CALL DRSCL( K1, ALPHA, DWORK(K2), 1 ) + P1 = DWORK(K2) + PK1 = DWORK(K2+K1-1) +C + DO 100 I = 1, K1 - 1 + DWORK(K+I) = P1*DWORK(DP+1+I) - PK1*DWORK(K2+K1-I) + 100 CONTINUE +C +C Compute the number of unstable zeros. +C + K = K + 1 + IF ( DWORK(K).EQ.ZERO ) THEN + INFO = 2 + ELSE + SIGNUM = SIGNUM*SIGN( ONE, DWORK(K) ) + IF ( SIGNUM.LT.ZERO ) NZ = NZ + 1 + END IF + GO TO 80 + END IF +C END WHILE 80 + END IF + END IF +C + IF ( ( INFO.EQ.0 ) .AND. ( NZ.EQ.0 ) ) THEN + STABLE = .TRUE. + ELSE + STABLE = .FALSE. + END IF +C + RETURN +C *** Last line of MC01TD *** + END diff --git a/mex/sources/libslicot/MC01VD.f b/mex/sources/libslicot/MC01VD.f new file mode 100644 index 000000000..4d03390b1 --- /dev/null +++ b/mex/sources/libslicot/MC01VD.f @@ -0,0 +1,304 @@ + SUBROUTINE MC01VD( A, B, C, Z1RE, Z1IM, Z2RE, Z2IM, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the roots of a quadratic equation with real +C coefficients. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input) DOUBLE PRECISION +C The value of the coefficient of the quadratic term. +C +C B (input) DOUBLE PRECISION +C The value of the coefficient of the linear term. +C +C C (input) DOUBLE PRECISION +C The value of the coefficient of the constant term. +C +C Z1RE (output) DOUBLE PRECISION +C Z1IM (output) DOUBLE PRECISION +C The real and imaginary parts, respectively, of the largest +C root in magnitude. +C +C Z2RE (output) DOUBLE PRECISION +C Z2IM (output) DOUBLE PRECISION +C The real and imaginary parts, respectively, of the +C smallest root in magnitude. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if on entry, either A = B = 0.0 or A = 0.0 and the +C root -C/B overflows; in this case Z1RE, Z1IM, Z2RE +C and Z2IM are unassigned; +C = 2: if on entry, A = 0.0; in this case Z1RE contains +C BIG and Z1IM contains zero, where BIG is a +C representable number near the overflow threshold +C of the machine (see LAPACK Library Routine DLAMCH); +C = 3: if on entry, either C = 0.0 and the root -B/A +C overflows or A, B and C are non-zero and the largest +C real root in magnitude cannot be computed without +C overflow; in this case Z1RE contains BIG and Z1IM +C contains zero; +C = 4: if the roots cannot be computed without overflow; in +C this case Z1RE, Z1IM, Z2RE and Z2IM are unassigned. +C +C METHOD +C +C The routine computes the roots (r1 and r2) of the real quadratic +C equation +C 2 +C a * x + b * x + c = 0 +C +C as +C - b - SIGN(b) * SQRT(b * b - 4 * a * c) c +C r1 = --------------------------------------- and r2 = ------ +C 2 * a a * r1 +C +C unless a = 0, in which case +C +C -c +C r1 = --. +C b +C +C Precautions are taken to avoid overflow and underflow wherever +C possible. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01JD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Quadratic equation, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, FOUR + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR=4.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO + DOUBLE PRECISION A, B, C, Z1IM, Z1RE, Z2IM, Z2RE +C .. Local Scalars .. + LOGICAL OVFLOW + INTEGER BETA, EA, EAPLEC, EB, EB2, EC, ED + DOUBLE PRECISION ABSA, ABSB, ABSC, BIG, M1, M2, MA, MB, MC, MD, + $ SFMIN, W +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL MC01SW, MC01SY +C .. Intrinsic Functions .. + INTRINSIC ABS, MOD, SIGN, SQRT +C .. Executable Statements .. +C +C Detect special cases. +C + INFO = 0 + BETA = DLAMCH( 'Base' ) + SFMIN = DLAMCH( 'Safe minimum' ) + BIG = ONE/SFMIN + IF ( A.EQ.ZERO ) THEN + IF ( B.EQ.ZERO ) THEN + INFO = 1 + ELSE + OVFLOW = .FALSE. + Z2RE = ZERO + IF ( C.NE.ZERO ) THEN + ABSB = ABS( B ) + IF ( ABSB.GE.ONE ) THEN + IF ( ABS( C ).GE.ABSB*SFMIN ) Z2RE = -C/B + ELSE + IF ( ABS( C ).LE.ABSB*BIG ) THEN + Z2RE = -C/B + ELSE + OVFLOW = .TRUE. + Z2RE = BIG + IF ( SIGN( ONE, B )*SIGN( ONE, C ).GT.ZERO ) + $ Z2RE = -BIG + END IF + END IF + END IF + IF ( OVFLOW ) THEN + INFO = 1 + ELSE + Z1RE = BIG + Z1IM = ZERO + Z2IM = ZERO + INFO = 2 + END IF + END IF + RETURN + END IF +C + IF ( C.EQ.ZERO ) THEN + OVFLOW = .FALSE. + Z1RE = ZERO + IF ( B.NE.ZERO ) THEN + ABSA = ABS( A ) + IF ( ABSA.GE.ONE ) THEN + IF ( ABS( B ).GE.ABSA*SFMIN ) Z1RE = -B/A + ELSE + IF ( ABS( B ).LE.ABSA*BIG ) THEN + Z1RE = -B/A + ELSE + OVFLOW = .TRUE. + Z1RE = BIG + END IF + END IF + END IF + IF ( OVFLOW ) INFO = 3 + Z1IM = ZERO + Z2RE = ZERO + Z2IM = ZERO + RETURN + END IF +C +C A and C are non-zero. +C + IF ( B.EQ.ZERO ) THEN + OVFLOW = .FALSE. + ABSC = SQRT( ABS( C ) ) + ABSA = SQRT( ABS( A ) ) + W = ZERO + IF ( ABSA.GE.ONE ) THEN + IF ( ABSC.GE.ABSA*SFMIN ) W = ABSC/ABSA + ELSE + IF ( ABSC.LE.ABSA*BIG ) THEN + W = ABSC/ABSA + ELSE + OVFLOW = .TRUE. + W = BIG + END IF + END IF + IF ( OVFLOW ) THEN + INFO = 4 + ELSE + IF ( SIGN( ONE, A )*SIGN( ONE, C ).GT.ZERO ) THEN + Z1RE = ZERO + Z2RE = ZERO + Z1IM = W + Z2IM = -W + ELSE + Z1RE = W + Z2RE = -W + Z1IM = ZERO + Z2IM = ZERO + END IF + END IF + RETURN + END IF +C +C A, B and C are non-zero. +C + CALL MC01SW( A, BETA, MA, EA ) + CALL MC01SW( B, BETA, MB, EB ) + CALL MC01SW( C, BETA, MC, EC ) +C +C Compute a 'near' floating-point representation of the discriminant +C D = MD * BETA**ED. +C + EAPLEC = EA + EC + EB2 = 2*EB + IF ( EAPLEC.GT.EB2 ) THEN + CALL MC01SY( MB*MB, EB2-EAPLEC, BETA, W, OVFLOW ) + W = W - FOUR*MA*MC + CALL MC01SW( W, BETA, MD, ED ) + ED = ED + EAPLEC + ELSE + CALL MC01SY( FOUR*MA*MC, EAPLEC-EB2, BETA, W, OVFLOW ) + W = MB*MB - W + CALL MC01SW( W, BETA, MD, ED ) + ED = ED + EB2 + END IF +C + IF ( MOD( ED, 2 ).NE.0 ) THEN + ED = ED + 1 + MD = MD/BETA + END IF +C +C Complex roots. +C + IF ( MD.LT.ZERO ) THEN + CALL MC01SY( -MB/( 2*MA ), EB-EA, BETA, Z1RE, OVFLOW ) + IF ( OVFLOW ) THEN + INFO = 4 + ELSE + CALL MC01SY( SQRT( -MD )/( 2*MA ), ED/2-EA, BETA, Z1IM, + $ OVFLOW ) + IF ( OVFLOW ) THEN + INFO = 4 + ELSE + Z2RE = Z1RE + Z2IM = -Z1IM + END IF + END IF + RETURN + END IF +C +C Real roots. +C + MD = SQRT( MD ) + ED = ED/2 + IF ( ED.GT.EB ) THEN + CALL MC01SY( ABS( MB ), EB-ED, BETA, W, OVFLOW ) + W = W + MD + M1 = -SIGN( ONE, MB )*W/( 2*MA ) + CALL MC01SY( M1, ED-EA, BETA, Z1RE, OVFLOW ) + IF ( OVFLOW ) THEN + Z1RE = BIG + INFO = 3 + END IF + M2 = -SIGN( ONE, MB )*2*MC/W + CALL MC01SY( M2, EC-ED, BETA, Z2RE, OVFLOW ) + ELSE + CALL MC01SY( MD, ED-EB, BETA, W, OVFLOW ) + W = W + ABS( MB ) + M1 = -SIGN( ONE, MB )*W/( 2*MA ) + CALL MC01SY( M1, EB-EA, BETA, Z1RE, OVFLOW ) + IF ( OVFLOW ) THEN + Z1RE = BIG + INFO = 3 + END IF + M2 = -SIGN( ONE, MB )*2*MC/W + CALL MC01SY( M2, EC-EB, BETA, Z2RE, OVFLOW ) + END IF + Z1IM = ZERO + Z2IM = ZERO +C + RETURN +C *** Last line of MC01VD *** + END diff --git a/mex/sources/libslicot/MC01WD.f b/mex/sources/libslicot/MC01WD.f new file mode 100644 index 000000000..5ef42154c --- /dev/null +++ b/mex/sources/libslicot/MC01WD.f @@ -0,0 +1,156 @@ + SUBROUTINE MC01WD( DP, P, U1, U2, Q, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a given real polynomial P(x) and a quadratic +C polynomial B(x), the quotient polynomial Q(x) and the linear +C remainder polynomial R(x) such that +C +C P(x) = B(x) * Q(x) + R(x), +C +C 2 +C where B(x) = u1 + u2 * x + x , R(x) = q(1) + q(2) * (u2 + x) +C and u1, u2, q(1) and q(2) are real scalars. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DP (input) INTEGER +C The degree of the polynomial P(x). DP >= 0. +C +C P (input) DOUBLE PRECISION array, dimension (DP+1) +C This array must contain the coefficients of P(x) in +C increasing powers of x. +C +C U1 (input) DOUBLE PRECISION +C The value of the constant term of the quadratic +C polynomial B(x). +C +C U2 (input) DOUBLE PRECISION +C The value of the coefficient of x of the quadratic +C polynomial B(x). +C +C Q (output) DOUBLE PRECISION array, dimension (DP+1) +C If DP >= 1 on entry, then elements Q(1) and Q(2) contain +C the coefficients q(1) and q(2), respectively, of the +C remainder polynomial R(x), and the next (DP-1) elements +C of this array contain the coefficients of the quotient +C polynomial Q(x) in increasing powers of x. +C If DP = 0 on entry, then element Q(1) contains the +C coefficient q(1) of the remainder polynomial R(x) = q(1); +C Q(x) is the zero polynomial. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given the real polynomials +C +C DP i 2 +C P(x) = SUM p(i+1) * x and B(x) = u1 + u2 * x + x +C i=0 +C +C the routine uses the recurrence relationships +C +C q(DP+1) = p(DP+1), +C +C q(DP) = p(DP) - u2 * q(DP+1) and +C +C q(i) = p(i) - u2 * q(i+1) - u1 * q(i+2) for i = DP-1, ..., 1 +C +C to determine the coefficients of the quotient polynomial +C +C DP-2 i +C Q(x) = SUM q(i+3) * x +C i=0 +C +C and the remainder polynomial +C +C R(x) = q(1) + q(2) * (u2 + x). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC01KD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, polynomial operations, +C quadratic polynomial. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER DP, INFO + DOUBLE PRECISION U1, U2 +C .. Array Arguments .. + DOUBLE PRECISION P(*), Q(*) +C .. Local Scalars .. + INTEGER I, N + DOUBLE PRECISION A, B, C +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + IF ( DP.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'MC01WD', -INFO ) + RETURN + END IF +C + INFO = 0 + N = DP + 1 + Q(N) = P(N) + IF ( N.GT.1 ) THEN + B = Q(N) + Q(N-1) = P(N-1) - U2*B + IF ( N.GT.2 ) THEN + A = Q(N-1) +C + DO 20 I = N - 2, 1, -1 + C = P(I) - U2*A - U1*B + Q(I) = C + B = A + A = C + 20 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of MC01WD *** + END diff --git a/mex/sources/libslicot/MC03MD.f b/mex/sources/libslicot/MC03MD.f new file mode 100644 index 000000000..36e69719c --- /dev/null +++ b/mex/sources/libslicot/MC03MD.f @@ -0,0 +1,351 @@ + SUBROUTINE MC03MD( RP1, CP1, CP2, DP1, DP2, DP3, ALPHA, P1, + $ LDP11, LDP12, P2, LDP21, LDP22, P3, LDP31, + $ LDP32, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of the real polynomial matrix +C +C P(x) = P1(x) * P2(x) + alpha * P3(x), +C +C where P1(x), P2(x) and P3(x) are given real polynomial matrices +C and alpha is a real scalar. +C +C Each of the polynomial matrices P1(x), P2(x) and P3(x) may be the +C zero matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C RP1 (input) INTEGER +C The number of rows of the matrices P1(x) and P3(x). +C RP1 >= 0. +C +C CP1 (input) INTEGER +C The number of columns of matrix P1(x) and the number of +C rows of matrix P2(x). CP1 >= 0. +C +C CP2 (input) INTEGER +C The number of columns of the matrices P2(x) and P3(x). +C CP2 >= 0. +C +C DP1 (input) INTEGER +C The degree of the polynomial matrix P1(x). DP1 >= -1. +C +C DP2 (input) INTEGER +C The degree of the polynomial matrix P2(x). DP2 >= -1. +C +C DP3 (input/output) INTEGER +C On entry, the degree of the polynomial matrix P3(x). +C DP3 >= -1. +C On exit, the degree of the polynomial matrix P(x). +C +C ALPHA (input) DOUBLE PRECISION +C The scalar value alpha of the problem. +C +C P1 (input) DOUBLE PRECISION array, dimension (LDP11,LDP12,*) +C If DP1 >= 0, then the leading RP1-by-CP1-by-(DP1+1) part +C of this array must contain the coefficients of the +C polynomial matrix P1(x). Specifically, P1(i,j,k) must +C contain the coefficient of x**(k-1) of the polynomial +C which is the (i,j)-th element of P1(x), where i = 1,2,..., +C RP1, j = 1,2,...,CP1 and k = 1,2,...,DP1+1. +C If DP1 = -1, then P1(x) is taken to be the zero polynomial +C matrix, P1 is not referenced and can be supplied as a +C dummy array (i.e. set the parameters LDP11 = LDP12 = 1 and +C declare this array to be P1(1,1,1) in the calling +C program). +C +C LDP11 INTEGER +C The leading dimension of array P1. +C LDP11 >= MAX(1,RP1) if DP1 >= 0, +C LDP11 >= 1 if DP1 = -1. +C +C LDP12 INTEGER +C The second dimension of array P1. +C LDP12 >= MAX(1,CP1) if DP1 >= 0, +C LDP12 >= 1 if DP1 = -1. +C +C P2 (input) DOUBLE PRECISION array, dimension (LDP21,LDP22,*) +C If DP2 >= 0, then the leading CP1-by-CP2-by-(DP2+1) part +C of this array must contain the coefficients of the +C polynomial matrix P2(x). Specifically, P2(i,j,k) must +C contain the coefficient of x**(k-1) of the polynomial +C which is the (i,j)-th element of P2(x), where i = 1,2,..., +C CP1, j = 1,2,...,CP2 and k = 1,2,...,DP2+1. +C If DP2 = -1, then P2(x) is taken to be the zero polynomial +C matrix, P2 is not referenced and can be supplied as a +C dummy array (i.e. set the parameters LDP21 = LDP22 = 1 and +C declare this array to be P2(1,1,1) in the calling +C program). +C +C LDP21 INTEGER +C The leading dimension of array P2. +C LDP21 >= MAX(1,CP1) if DP2 >= 0, +C LDP21 >= 1 if DP2 = -1. +C +C LDP22 INTEGER +C The second dimension of array P2. +C LDP22 >= MAX(1,CP2) if DP2 >= 0, +C LDP22 >= 1 if DP2 = -1. +C +C P3 (input/output) DOUBLE PRECISION array, dimension +C (LDP31,LDP32,n), where n = MAX(DP1+DP2,DP3,0)+1. +C On entry, if DP3 >= 0, then the leading +C RP1-by-CP2-by-(DP3+1) part of this array must contain the +C coefficients of the polynomial matrix P3(x). Specifically, +C P3(i,j,k) must contain the coefficient of x**(k-1) of the +C polynomial which is the (i,j)-th element of P3(x), where +C i = 1,2,...,RP1, j = 1,2,...,CP2 and k = 1,2,...,DP3+1. +C If DP3 = -1, then P3(x) is taken to be the zero polynomial +C matrix. +C On exit, if DP3 >= 0 on exit (ALPHA <> 0.0 and DP3 <> -1, +C on entry, or DP1 <> -1 and DP2 <> -1), then the leading +C RP1-by-CP2-by-(DP3+1) part of this array contains the +C coefficients of P(x). Specifically, P3(i,j,k) contains the +C coefficient of x**(k-1) of the polynomial which is the +C (i,j)-th element of P(x), where i = 1,2,...,RP1, j = 1,2, +C ...,CP2 and k = 1,2,...,DP3+1. +C If DP3 = -1 on exit, then the coefficients of P(x) (the +C zero polynomial matrix) are not stored in the array. +C +C LDP31 INTEGER +C The leading dimension of array P3. LDP31 >= MAX(1,RP1). +C +C LDP32 INTEGER +C The second dimension of array P3. LDP32 >= MAX(1,CP2). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (CP1) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given real polynomial matrices +C +C DP1 i +C P1(x) = SUM (A(i+1) * x ), +C i=0 +C +C DP2 i +C P2(x) = SUM (B(i+1) * x ), +C i=0 +C +C DP3 i +C P3(x) = SUM (C(i+1) * x ) +C i=0 +C +C and a real scalar alpha, the routine computes the coefficients +C d ,d ,..., of the polynomial matrix +C 1 2 +C +C P(x) = P1(x) * P2(x) + alpha * P3(x) +C +C from the formula +C +C s +C d = SUM (A(k+1) * B(i-k+1)) + alpha * C(i+1), +C i+1 k=r +C +C where i = 0,1,...,DP1+DP2 and r and s depend on the value of i +C (e.g. if i <= DP1 and i <= DP2, then r = 0 and s = i). +C +C NUMERICAL ASPECTS +C +C None. +C +C FURTHER COMMENTS +C +C Other elementary operations involving polynomial matrices can +C easily be obtained by calling the appropriate BLAS routine(s). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC03AD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, input output description, +C polynomial matrix, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER CP1, CP2, DP1, DP2, DP3, INFO, LDP11, LDP12, + $ LDP21, LDP22, LDP31, LDP32, RP1 + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), P1(LDP11,LDP12,*), P2(LDP21,LDP22,*), + $ P3(LDP31,LDP32,*) +C .. Local Scalars .. + LOGICAL CFZERO + INTEGER DPOL3, E, H, I, J, K +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DCOPY, DLASET, DSCAL, XERBLA +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + INFO = 0 + IF( RP1.LT.0 ) THEN + INFO = -1 + ELSE IF( CP1.LT.0 ) THEN + INFO = -2 + ELSE IF( CP2.LT.0 ) THEN + INFO = -3 + ELSE IF( DP1.LT.-1 ) THEN + INFO = -4 + ELSE IF( DP2.LT.-1 ) THEN + INFO = -5 + ELSE IF( DP3.LT.-1 ) THEN + INFO = -6 + ELSE IF( ( DP1.EQ.-1 .AND. LDP11.LT.1 ) .OR. + $ ( DP1.GE. 0 .AND. LDP11.LT.MAX( 1, RP1 ) ) ) THEN + INFO = -9 + ELSE IF( ( DP1.EQ.-1 .AND. LDP12.LT.1 ) .OR. + $ ( DP1.GE. 0 .AND. LDP12.LT.MAX( 1, CP1 ) ) ) THEN + INFO = -10 + ELSE IF( ( DP2.EQ.-1 .AND. LDP21.LT.1 ) .OR. + $ ( DP2.GE. 0 .AND. LDP21.LT.MAX( 1, CP1 ) ) ) THEN + INFO = -12 + ELSE IF( ( DP2.EQ.-1 .AND. LDP22.LT.1 ) .OR. + $ ( DP2.GE. 0 .AND. LDP22.LT.MAX( 1, CP2 ) ) ) THEN + INFO = -13 + ELSE IF( LDP31.LT.MAX( 1, RP1 ) ) THEN + INFO = -15 + ELSE IF( LDP32.LT.MAX( 1, CP2 ) ) THEN + INFO = -16 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC03MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( RP1.EQ.0 .OR. CP2.EQ.0 ) + $ RETURN +C + IF ( ALPHA.EQ.ZERO ) + $ DP3 = -1 +C + IF ( DP3.GE.0 ) THEN +C +C P3(x) := ALPHA * P3(x). +C + DO 40 K = 1, DP3 + 1 +C + DO 20 J = 1, CP2 + CALL DSCAL( RP1, ALPHA, P3(1,J,K), 1 ) + 20 CONTINUE +C + 40 CONTINUE + END IF +C + IF ( ( DP1.EQ.-1 ) .OR. ( DP2.EQ.-1 ) .OR. ( CP1.EQ.0 ) ) + $ RETURN +C +C Neither of P1(x) and P2(x) is the zero polynomial. +C + DPOL3 = DP1 + DP2 + IF ( DPOL3.GT.DP3 ) THEN +C +C Initialize the additional part of P3(x) to zero. +C + DO 80 K = DP3 + 2, DPOL3 + 1 + CALL DLASET( 'Full', RP1, CP2, ZERO, ZERO, P3(1,1,K), + $ LDP31 ) + 80 CONTINUE +C + DP3 = DPOL3 + END IF +C k-1 +C The inner product of the j-th row of the coefficient of x of P1 +C i-1 +C and the h-th column of the coefficient of x of P2(x) contribute +C k+i-2 +C the (j,h)-th element of the coefficient of x of P3(x). +C + DO 160 K = 1, DP1 + 1 +C + DO 140 J = 1, RP1 + CALL DCOPY( CP1, P1(J,1,K), LDP11, DWORK, 1 ) +C + DO 120 I = 1, DP2 + 1 + E = K + I - 1 +C + DO 100 H = 1, CP2 + P3(J,H,E) = DDOT( CP1, DWORK, 1, P2(1,H,I), 1 ) + + $ P3(J,H,E) + 100 CONTINUE +C + 120 CONTINUE +C + 140 CONTINUE +C + 160 CONTINUE +C +C Computation of the exact degree of P3(x). +C + CFZERO = .TRUE. +C WHILE ( DP3 >= 0 and CFZERO ) DO + 180 IF ( ( DP3.GE.0 ) .AND. CFZERO ) THEN + DPOL3 = DP3 + 1 +C + DO 220 J = 1, CP2 +C + DO 200 I = 1, RP1 + IF ( P3(I,J,DPOL3 ).NE.ZERO ) CFZERO = .FALSE. + 200 CONTINUE +C + 220 CONTINUE +C + IF ( CFZERO ) DP3 = DP3 - 1 + GO TO 180 + END IF +C END WHILE 180 +C + RETURN +C *** Last line of MC03MD *** + END diff --git a/mex/sources/libslicot/MC03ND.f b/mex/sources/libslicot/MC03ND.f new file mode 100644 index 000000000..5ee0fd02a --- /dev/null +++ b/mex/sources/libslicot/MC03ND.f @@ -0,0 +1,495 @@ + SUBROUTINE MC03ND( MP, NP, DP, P, LDP1, LDP2, DK, GAM, NULLSP, + $ LDNULL, KER, LDKER1, LDKER2, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of a minimal polynomial basis +C DK +C K(s) = K(0) + K(1) * s + ... + K(DK) * s +C +C for the right nullspace of the MP-by-NP polynomial matrix of +C degree DP, given by +C DP +C P(s) = P(0) + P(1) * s + ... + P(DP) * s , +C +C which corresponds to solving the polynomial matrix equation +C P(s) * K(s) = 0. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the polynomial matrix P(s). +C MP >= 0. +C +C NP (input) INTEGER +C The number of columns of the polynomial matrix P(s). +C NP >= 0. +C +C DP (input) INTEGER +C The degree of the polynomial matrix P(s). DP >= 1. +C +C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array must +C contain the coefficients of the polynomial matrix P(s). +C Specifically, P(i,j,k) must contain the (i,j)-th element +C of P(k-1), which is the cofficient of s**(k-1) of P(s), +C where i = 1,2,...,MP, j = 1,2,...,NP and k = 1,2,...,DP+1. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MAX(1,MP). +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= MAX(1,NP). +C +C DK (output) INTEGER +C The degree of the minimal polynomial basis K(s) for the +C right nullspace of P(s) unless DK = -1, in which case +C there is no right nullspace. +C +C GAM (output) INTEGER array, dimension (DP*MP+1) +C The leading (DK+1) elements of this array contain +C information about the ordering of the right nullspace +C vectors stored in array NULLSP. +C +C NULLSP (output) DOUBLE PRECISION array, dimension +C (LDNULL,(DP*MP+1)*NP) +C The leading NP-by-SUM(i*GAM(i)) part of this array +C contains the right nullspace vectors of P(s) in condensed +C form (as defined in METHOD), where i = 1,2,...,DK+1. +C +C LDNULL INTEGER +C The leading dimension of array NULLSP. +C LDNULL >= MAX(1,NP). +C +C KER (output) DOUBLE PRECISION array, dimension +C (LDKER1,LDKER2,DP*MP+1) +C The leading NP-by-nk-by-(DK+1) part of this array contains +C the coefficients of the minimal polynomial basis K(s), +C where nk = SUM(GAM(i)) and i = 1,2,...,DK+1. Specifically, +C KER(i,j,m) contains the (i,j)-th element of K(m-1), which +C is the coefficient of s**(m-1) of K(s), where i = 1,2,..., +C NP, j = 1,2,...,nk and m = 1,2,...,DK+1. +C +C LDKER1 INTEGER +C The leading dimension of array KER. LDKER1 >= MAX(1,NP). +C +C LDKER2 INTEGER +C The second dimension of array KER. LDKER2 >= MAX(1,NP). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C A tolerance below which matrix elements are considered +C to be zero. If the user sets TOL to be less than +C 10 * EPS * MAX( ||A|| , ||E|| ), then the tolerance is +C F F +C taken as 10 * EPS * MAX( ||A|| , ||E|| ), where EPS is the +C F F +C machine precision (see LAPACK Library Routine DLAMCH) and +C A and E are matrices (as defined in METHOD). +C +C Workspace +C +C IWORK INTEGER array, dimension (m+2*MAX(n,m+1)+n), +C where m = DP*MP and n = (DP-1)*MP + NP. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK The length of the array DWORK. +C LDWORK >= m*n*n + 2*m*n + 2*n*n. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C > 0: if incorrect rank decisions were taken during the +C computations. This failure is not likely to occur. +C The possible values are: +C k, 1 <= k <= DK+1, the k-th diagonal submatrix had +C not a full row rank; +C DK+2, if incorrect dimensions of a full column +C rank submatrix; +C DK+3, if incorrect dimensions of a full row rank +C submatrix. +C +C METHOD +C +C The computation of the right nullspace of the MP-by-NP polynomial +C matrix P(s) of degree DP given by +C DP-1 DP +C P(s) = P(0) + P(1) * s + ... + P(DP-1) * s + P(DP) * s +C +C is performed via the pencil s*E - A, associated with P(s), where +C +C | I | | 0 -P(DP) | +C | . | | I . . | +C A = | . | and E = | . . . |. (1) +C | . | | . 0 . | +C | I | | I 0 -P(2) | +C | P(0) | | I -P(1) | +C +C The pencil s*E - A is transformed by unitary matrices Q and Z such +C that +C +C | sE(eps)-A(eps) | X | X | +C |----------------|----------------|------------| +C | 0 | sE(inf)-A(inf) | X | +C Q'(s*E-A)Z = |=================================|============|. +C | | | +C | 0 | sE(r)-A(r) | +C +C Since s*E(inf)-A(inf) and s*E(r)-A(r) have full column rank, the +C minimal polynomial basis for the right nullspace of Q'(s*E-A)Z +C (and consequently the basis for the right nullspace of s*E - A) is +C completely determined by s*E(eps)-A(eps). +C +C Let Veps(s) be a minimal polynomial basis for the right nullspace +C of s*E(eps)-A(eps). Then +C +C | Veps(s) | +C V(s) = Z * |---------| +C | 0 | +C +C is a minimal polynomial basis for the right nullspace of s*E - A. +C From the structure of s*E - A it can be shown that if V(s) is +C partitioned as +C +C | Vo(s) | (DP-1)*MP +C V(s) = |------ | +C | Ve(s) | NP +C +C then the columns of Ve(s) form a minimal polynomial basis for the +C right nullspace of P(s). +C +C The vectors of Ve(s) are computed and stored in array NULLSP in +C the following condensed form: +C +C || || | || | | || | | +C || U1,0 || U2,0 | U2,1 || U3,0 | U3,1 | U3,2 || U4,0 | ... |, +C || || | || | | || | | +C +C where Ui,j is an NP-by-GAM(i) matrix which contains the i-th block +C of columns of K(j), the j-th coefficient of the polynomial matrix +C representation for the right nullspace +C DK +C K(s) = K(0) + K(1) * s + . . . + K(DK) * s . +C +C The coefficients K(0), K(1), ..., K(DK) are NP-by-nk matrices +C given by +C +C K(0) = | U1,0 | U2,0 | U3,0 | . . . | U(DK+1,0) | +C +C K(1) = | 0 | U2,1 | U3,1 | . . . | U(DK+1,1) | +C +C K(2) = | 0 | 0 | U3,2 | . . . | U(DK+1,2) | +C +C . . . . . . . . . . +C +C K(DK) = | 0 | 0 | 0 | . . . | 0 | U(DK+1,DK)|. +C +C Note that the degree of K(s) satisfies the inequality DK <= +C DP * MIN(MP,NP) and that the dimension of K(s) satisfies the +C inequality (NP-MP) <= nk <= NP. +C +C REFERENCES +C +C [1] Beelen, Th.G.J. +C New Algorithms for Computing the Kronecker structure of a +C Pencil with Applications to Systems and Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, 1987. +C +C [2] Van Den Hurk, G.J.H.H. +C New Algorithms for Solving Polynomial Matrix Problems. +C Master's Thesis, Eindhoven University of Technology, 1987. +C +C NUMERICAL ASPECTS +C +C The algorithm used by the routine involves the construction of a +C special block echelon form with pivots considered to be non-zero +C when they are larger than TOL. These pivots are then inverted in +C order to construct the columns of the kernel of the polynomial +C matrix. If TOL is chosen to be too small then these inversions may +C be sensitive whereas increasing TOL will make the inversions more +C robust but will affect the block echelon form (and hence the +C column degrees of the polynomial kernel). Furthermore, if the +C elements of the computed polynomial kernel are large relative to +C the polynomial matrix, then the user should consider trying +C several values of TOL. +C +C FURTHER COMMENTS +C +C It also possible to compute a minimal polynomial basis for the +C right nullspace of a pencil, since a pencil is a polynomial matrix +C of degree 1. Thus for the pencil (s*E - A), the required input is +C P(1) = E and P(0) = -A. +C +C The routine can also be used to compute a minimal polynomial +C basis for the left nullspace of a polynomial matrix by simply +C transposing P(s). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC03BD by A.J. Geurts and MC03BZ by +C Th.G.J. Beelen, A.J. Geurts, and G.J.H.H. van den Hurk. +C +C REVISIONS +C +C Jan. 1998. +C +C KEYWORDS +C +C Echelon form, elementary polynomial operations, input output +C description, polynomial matrix, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TEN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) +C .. Scalar Arguments .. + INTEGER DK, DP, INFO, LDKER1, LDKER2, LDNULL, LDP1, + $ LDP2, LDWORK, MP, NP + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER GAM(*), IWORK(*) + DOUBLE PRECISION DWORK(*), KER(LDKER1,LDKER2,*), + $ NULLSP(LDNULL,*), P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER GAMJ, H, I, IDIFF, IFIR, J, JWORKA, JWORKE, + $ JWORKQ, JWORKV, JWORKZ, K, M, MUK, N, NBLCKS, + $ NBLCKI, NCA, NCV, NRA, NUK, RANKE, SGAMK, TAIL, + $ VC1, VR2 + DOUBLE PRECISION TOLER +C .. Local Arrays .. + INTEGER MNEI(3) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 + EXTERNAL DLAMCH, DLANGE, DLAPY2 +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, MB04UD, MB04VD, MC03NX, + $ MC03NY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, SQRT +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + M = DP*MP + H = M - MP + N = H + NP + INFO = 0 + IF( MP.LT.0 ) THEN + INFO = -1 + ELSE IF( NP.LT.0 ) THEN + INFO = -2 + ELSE IF( DP.LE.0 ) THEN + INFO = -3 + ELSE IF( LDP1.LT.MAX( 1, MP ) ) THEN + INFO = -5 + ELSE IF( LDP2.LT.MAX( 1, NP ) ) THEN + INFO = -6 + ELSE IF( LDNULL.LT.MAX( 1, NP ) ) THEN + INFO = -10 + ELSE IF( LDKER1.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDKER2.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDWORK.LT.( N*( M*N + 2*( M + N ) ) ) ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC03ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MP.EQ.0 .OR. NP.EQ.0 ) THEN + DK = -1 + RETURN + END IF +C + JWORKA = 1 + JWORKE = JWORKA + M*N + JWORKZ = JWORKE + M*N + JWORKV = JWORKZ + N*N + JWORKQ = JWORKA +C +C Construct the matrices A and E in the pencil s*E-A in (1). +C Workspace: 2*M*N. +C + CALL MC03NX( MP, NP, DP, P, LDP1, LDP2, DWORK(JWORKA), M, + $ DWORK(JWORKE), M ) +C +C Computation of the tolerance. +C + TOLER = MAX( DLANGE( 'F', M, NP, DWORK(JWORKE+H*M), M, DWORK ), + $ DLANGE( 'F', MP, NP, P, LDP1, DWORK ) ) + TOLER = TEN*DLAMCH( 'Epsilon' ) + $ *DLAPY2( TOLER, SQRT( DBLE( H ) ) ) + IF ( TOLER.LE.TOL ) TOLER = TOL +C +C Reduction of E to column echelon form E0 = Q' x E x Z and +C transformation of A, A0 = Q' x A x Z. +C Workspace: 2*M*N + N*N + max(M,N). +C + CALL MB04UD( 'No Q', 'Identity Z', M, N, DWORK(JWORKA), M, + $ DWORK(JWORKE), M, DWORK(JWORKQ), M, DWORK(JWORKZ), N, + $ RANKE, IWORK, TOLER, DWORK(JWORKV), INFO ) +C +C The contents of ISTAIR is transferred from MB04UD to MB04VD by +C IWORK(i), i=1,...,M. +C In the sequel the arrays IMUK and INUK are part of IWORK, namely: +C IWORK(i), i = M+1,...,M+max(N,M+1), contains IMUK, +C IWORK(i), i = M+max(N,M+1)+1,...,M+2*max(N,M+1), contains INUK. +C IWORK(i), i = M+2*max(N,M+1)+1,...,M+2*max(N,M+1)+N, contains +C IMUK0 (not needed), and is also used as workspace. +C + MUK = M + 1 + NUK = MUK + MAX( N, M+1 ) + TAIL = NUK + MAX( N, M+1 ) +C + CALL MB04VD( 'Separation', 'No Q', 'Update Z', M, N, RANKE, + $ DWORK(JWORKA), M, DWORK(JWORKE), M, DWORK(JWORKQ), M, + $ DWORK(JWORKZ), N, IWORK, NBLCKS, NBLCKI, IWORK(MUK), + $ IWORK(NUK), IWORK(TAIL), MNEI, TOLER, IWORK(TAIL), + $ INFO ) + IF ( INFO.GT.0 ) THEN +C +C Incorrect rank decisions. +C + INFO = INFO + NBLCKS + RETURN + END IF +C +C If NBLCKS < 1, or the column dimension of s*E(eps) - A(eps) is +C zero, then there is no right nullspace. +C + IF ( NBLCKS.LT.1 .OR. MNEI(2).EQ.0 ) THEN + DK = -1 + RETURN + END IF +C +C Start of the computation of the minimal basis. +C + DK = NBLCKS - 1 + NRA = MNEI(1) + NCA = MNEI(2) +C +C Determine a minimal basis VEPS(s) for the right nullspace of the +C pencil s*E(eps)-A(eps) associated with the polynomial matrix P(s). +C Workspace: 2*M*N + N*N + N*N*(M+1). +C + CALL MC03NY( NBLCKS, NRA, NCA, DWORK(JWORKA), M, DWORK(JWORKE), M, + $ IWORK(MUK), IWORK(NUK), DWORK(JWORKV), N, INFO ) +C + IF ( INFO.GT.0 ) + $ RETURN +C + NCV = IWORK(MUK) - IWORK(NUK) + GAM(1) = NCV + IWORK(1) = 0 + IWORK(TAIL) = IWORK(MUK) +C + DO 20 I = 2, NBLCKS + IDIFF = IWORK(MUK+I-1) - IWORK(NUK+I-1) + GAM(I) = IDIFF + IWORK(I) = NCV + NCV = NCV + I*IDIFF + IWORK(TAIL+I-1) = IWORK(TAIL+I-2) + IWORK(MUK+I-1) + 20 CONTINUE +C +C Determine a basis for the right nullspace of the polynomial +C matrix P(s). This basis is stored in array NULLSP in condensed +C form. +C + CALL DLASET( 'Full', NP, NCV, ZERO, ZERO, NULLSP, LDNULL ) +C +C |VEPS(s)| +C The last NP rows of the product matrix Z x |-------| contain the +C | 0 | +C polynomial basis for the right nullspace of the polynomial matrix +C P(s) in condensed form. The multiplication is restricted to the +C nonzero submatrices Vij,k of VEPS, the result is stored in the +C array NULLSP. +C + VC1 = 1 +C + DO 60 I = 1, NBLCKS + VR2 = IWORK(TAIL+I-1) +C + DO 40 J = 1, I +C +C Multiplication of Z(H+1:N,1:VR2) with V.i,j-1 stored in +C VEPS(1:VR2,VC1:VC1+GAM(I)-1). +C + CALL DGEMM( 'No transpose', 'No transpose', NP, GAM(I), VR2, + $ ONE, DWORK(JWORKZ+H), N, + $ DWORK(JWORKV+(VC1-1)*N), N, ZERO, NULLSP(1,VC1), + $ LDNULL ) + VC1 = VC1 + GAM(I) + VR2 = VR2 - IWORK(MUK+I-J) + 40 CONTINUE +C + 60 CONTINUE +C +C Transfer of the columns of NULLSP to KER in order to obtain the +C polynomial matrix representation of K(s), the right nullspace +C of P(s). +C + SGAMK = 1 +C + DO 100 K = 1, NBLCKS + CALL DLASET( 'Full', NP, SGAMK-1, ZERO, ZERO, KER(1,1,K), + $ LDKER1 ) + IFIR = SGAMK +C +C Copy the appropriate columns of NULLSP into KER(k). +C SGAMK = 1 + SUM(i=1,..,k-1) GAM(i), is the first nontrivial +C column of KER(k), the first SGAMK - 1 columns of KER(k) are +C zero. IFIR denotes the position of the first column in KER(k) +C in the set of columns copied for a value of J. +C VC1 is the first column of NULLSP to be copied. +C + DO 80 J = K, NBLCKS + GAMJ = GAM(J) + VC1 = IWORK(J) + (K-1)*GAMJ + 1 + CALL DLACPY( 'Full', NP, GAMJ, NULLSP(1,VC1), LDNULL, + $ KER(1,IFIR,K), LDKER1 ) + IFIR = IFIR + GAMJ + 80 CONTINUE +C + SGAMK = SGAMK + GAM(K) + 100 CONTINUE +C + RETURN +C *** Last line of MC03ND *** + END diff --git a/mex/sources/libslicot/MC03NX.f b/mex/sources/libslicot/MC03NX.f new file mode 100644 index 000000000..7376234df --- /dev/null +++ b/mex/sources/libslicot/MC03NX.f @@ -0,0 +1,146 @@ + SUBROUTINE MC03NX( MP, NP, DP, P, LDP1, LDP2, A, LDA, E, LDE ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C Given an MP-by-NP polynomial matrix of degree dp +C dp-1 dp +C P(s) = P(0) + ... + P(dp-1) * s + P(dp) * s (1) +C +C the routine composes the related pencil s*E-A where +C +C | I | | O -P(dp) | +C | . | | I . . | +C A = | . | and E = | . . . |. (2) +C | . | | . O . | +C | I | | I O -P(2) | +C | P(0) | | I -P(1) | +C +C ================================================================== +C REMARK: This routine is intended to be called only from the SLICOT +C routine MC03ND. +C ================================================================== +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the polynomial matrix P(s). +C MP >= 0. +C +C NP (input) INTEGER +C The number of columns of the polynomial matrix P(s). +C NP >= 0. +C +C DP (input) INTEGER +C The degree of the polynomial matrix P(s). DP >= 1. +C +C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array must +C contain the coefficients of the polynomial matrix P(s) +C in (1) in increasing powers of s. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MAX(1,MP). +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= MAX(1,NP). +C +C A (output) DOUBLE PRECISION array, dimension +C (LDA,(DP-1)*MP+NP) +C The leading DP*MP-by-((DP-1)*MP+NP) part of this array +C contains the matrix A as described in (2). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,DP*MP). +C +C E (output) DOUBLE PRECISION array, dimension +C (LDE,(DP-1)*MP+NP) +C The leading DP*MP-by-((DP-1)*MP+NP) part of this array +C contains the matrix E as described in (2). +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,DP*MP). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC03BX by G.J.H.H. van den Hurk. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary polynomial operations, input output description, +C polynomial matrix, polynomial operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, LDA, LDE, LDP1, LDP2, MP, NP +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER H1, HB, HE, HI, J, K +C .. External Subroutines .. + EXTERNAL DLACPY, DLASET, DSCAL +C .. Executable Statements .. +C + IF ( MP.LE.0 .OR. NP.LE.0 ) + $ RETURN +C +C Initialisation of matrices A and E. +C + H1 = DP*MP + HB = H1 - MP + HE = HB + NP + CALL DLASET( 'Full', H1, HE, ZERO, ONE, A, LDA ) + CALL DLASET( 'Full', MP, HB, ZERO, ZERO, E, LDE ) + CALL DLACPY( 'Full', HB, HB, A, LDA, E(MP+1,1), LDE ) +C +C Insert the matrices P(0), P(1), ..., P(dp) at the right places +C in the matrices A and E. +C + HB = HB + 1 + CALL DLACPY( 'Full', MP, NP, P(1,1,1), LDP1, A(HB,HB), LDA ) + HI = 1 +C + DO 20 K = DP + 1, 2, -1 + CALL DLACPY( 'Full', MP, NP, P(1,1,K), LDP1, E(HI,HB), LDE ) + HI = HI + MP + 20 CONTINUE +C + DO 40 J = HB, HE + CALL DSCAL( H1, -ONE, E(1,J), 1 ) + 40 CONTINUE +C + RETURN +C *** Last line of MC03NX *** + END diff --git a/mex/sources/libslicot/MC03NY.f b/mex/sources/libslicot/MC03NY.f new file mode 100644 index 000000000..9966e02a5 --- /dev/null +++ b/mex/sources/libslicot/MC03NY.f @@ -0,0 +1,412 @@ + SUBROUTINE MC03NY( NBLCKS, NRA, NCA, A, LDA, E, LDE, IMUK, INUK, + $ VEPS, LDVEPS, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a minimal basis of the right nullspace of the +C subpencil s*E(eps)-A(eps) using the method given in [1] (see +C Eqs.(4.6.8), (4.6.9)). +C This pencil only contains Kronecker column indices, and it must be +C in staircase form as supplied by SLICOT Library Routine MB04VD. +C The basis vectors are represented by matrix V(s) having the form +C +C | V11(s) V12(s) V13(s) . . V1n(s) | +C | V22(s) V23(s) V2n(s) | +C | V33(s) . | +C V(s) = | . . | +C | . . | +C | . . | +C | Vnn(s) | +C +C where n is the number of full row rank blocks in matrix A(eps) and +C +C k j-i +C Vij(s) = Vij,0 + Vij,1*s +...+ Vij,k*s +...+ Vij,j-i*s . (1) +C +C In other words, Vij,k is the coefficient corresponding to degree k +C in the matrix polynomial Vij(s). +C Vij,k has dimensions mu(i)-by-(mu(j)-nu(j)). +C The coefficients Vij,k are stored in the matrix VEPS as follows +C (for the case n = 3): +C +C sizes m1-n1 m2-n2 m2-n2 m3-n3 m3-n3 m3-n3 +C +C m1 { | V11,0 || V12,0 | V12,1 || V13,0 | V13,1 | V13,2 || +C | || | || | | || +C VEPS = m2 { | || V22,0 | || V23,0 | V23,1 | || +C | || | || | | || +C m3 { | || | || V33,0 | | || +C +C where mi = mu(i), ni = nu(i). +C Matrix VEPS has dimensions nrv-by-ncv where +C nrv = Sum(i=1,...,n) mu(i) +C ncv = Sum(i=1,...,n) i*(mu(i)-nu(i)) +C +C ================================================================== +C REMARK: This routine is intended to be called only from the SLICOT +C routine MC03ND. +C ================================================================== +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NBLCKS (input) INTEGER +C Number of full row rank blocks in subpencil +C s*E(eps)-A(eps) that contains all Kronecker column indices +C of s*E-A. NBLCKS >= 0. +C +C NRA (input) INTEGER +C Number of rows of the subpencil s*E(eps)-A(eps) in s*E-A. +C NRA = nu(1) + nu(2) + ... + nu(NBLCKS). NRA >= 0. +C +C NCA (input) INTEGER +C Number of columns of the subpencil s*E(eps)-A(eps) in +C s*E-A. +C NCA = mu(1) + mu(2) + ... + mu(NBLCKS). NCA >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,NCA) +C E (input/output) DOUBLE PRECISION array, dimension (LDE,NCA) +C On entry, the leading NRA-by-NCA part of these arrays must +C contain the matrices A and E, where s*E-A is the +C transformed pencil s*E0-A0 which is the pencil associated +C with P(s) as described in [1] Section 4.6. The pencil +C s*E-A is assumed to be in generalized Schur form. +C On exit, these arrays contain no useful information. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,NRA). +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,NRA). +C +C IMUK (input) INTEGER array, dimension (NBLCKS) +C This array must contain the column dimensions mu(k) of the +C full column rank blocks in the subpencil s*E(eps)-A(eps) +C of s*E-A. The content of IMUK is modified by the routine +C but restored on exit. +C +C INUK (input) INTEGER array, dimension (NBLCKS) +C This array must contain the row dimensions nu(k) of the +C full row rank blocks in the subpencil s*E(eps)-A(eps) of +C s*E-A. +C +C VEPS (output) DOUBLE PRECISION array, dimension (LDVEPS,ncv) +C Let nrv = Sum(i=1,...,NBLCKS) mu(i) = NCA, +C ncv = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). +C The leading nrv-by-ncv part of this array contains the +C column vectors of a minimal polynomial basis for the right +C nullspace of the subpencil s*E(eps)-A(eps). (See [1] +C Section 4.6.4.) An upper bound for ncv is (NRA+1)*NCA. +C +C LDVEPS INTEGER +C The leading dimension of array VEPS. +C LDVEPS >= MAX(1,NCA). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = k, the k-th diagonal block of A had not a +C full row rank. +C +C REFERENCES +C +C [1] Th.G.J. Beelen, New Algorithms for Computing the Kronecker +C structure of a Pencil with Applications to Systems and +C Control Theory. +C Ph.D.Thesis, Eindhoven University of Technology, 1987. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997. +C Supersedes Release 2.0 routine MC03BY by Th.G.J. Beelen, +C A.J. Geurts, and G.J.H.H. van den Hurk. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Elementary polynomial operations, Kronecker form, polynomial +C matrix, polynomial operations, staircase form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDE, LDVEPS, NBLCKS, NCA, NRA +C .. Array Arguments .. + INTEGER IMUK(*), INUK(*) + DOUBLE PRECISION A(LDA,*), E(LDE,*), VEPS(LDVEPS,*) +C .. Local Scalars .. + INTEGER AC1, AC2, AR1, ARI, ARK, DIF, EC1, ER1, I, J, K, + $ MUI, NCV, NRV, NUI, SMUI, SMUI1, VC1, VC2, VR1, + $ VR2, WC1, WR1 +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLASET, DSCAL, DTRTRS, XERBLA +C .. Executable Statements .. +C + INFO = 0 + IF( NBLCKS.LT.0 ) THEN + INFO = -1 + ELSE IF( NRA.LT.0 ) THEN + INFO = -2 + ELSE IF( NCA.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, NRA ) ) THEN + INFO = -5 + ELSE IF( LDE.LT.MAX( 1, NRA ) ) THEN + INFO = -7 + ELSE IF( LDVEPS.LT.MAX( 1, NCA ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MC03NY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( NBLCKS.EQ.0 .OR. NRA.EQ.0 .OR. NCA.EQ.0 ) + $ RETURN +C +C Computation of the nonzero parts of W1 and W2: +C +C | AH11 AH12 ... AH1n | | EH11 EH12 ... EH1n | +C | AH22 AH2n | | EH22 EH2n | +C W1 = | . . |, W2 = | . . | +C | . . | | . . | +C | AHnn | | EHnn | +C +C with AHij = -pinv(Aii) * Aij, EHij = pinv(Aii) * Eij and EHii = 0, +C AHij and EHij have dimensions mu(i)-by-mu(j), Aii = [ Oi | Ri ], +C and +C Ri is a regular nu(i)-by-nu(i) upper triangular matrix; +C Oi is a not necessarily square null matrix. +C Note that the first mu(i)-nu(i) rows in AHij and EHij are zero. +C For memory savings, the nonzero parts of W1 and W2 are constructed +C over A and E, respectively. +C +C (AR1,AC1) denotes the position of the first element of the +C submatrix Ri in matrix Aii. +C EC1 is the index of the first column of Ai,i+1/Ei,i+1. +C + EC1 = 1 + AR1 = 1 +C + DO 40 I = 1, NBLCKS - 1 + NUI = INUK(I) + IF ( NUI.EQ.0 ) GO TO 60 + MUI = IMUK(I) + EC1 = EC1 + MUI + AC1 = EC1 - NUI + CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, + $ NCA-EC1+1, A(AR1,AC1), LDA, E(AR1,EC1), LDE, + $ INFO ) + IF ( INFO.GT.0 ) THEN + INFO = I + RETURN + END IF +C + DO 20 J = 1, NUI + CALL DSCAL( J, -ONE, A(AR1,AC1+J-1), 1 ) + 20 CONTINUE +C + CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', NUI, + $ NCA-EC1+1, A(AR1,AC1), LDA, A(AR1,EC1), LDA, + $ INFO ) + AR1 = AR1 + NUI + 40 CONTINUE +C + 60 CONTINUE +C +C The contents of the array IMUK is changed for temporary use in +C this routine as follows: +C +C IMUK(i) = Sum(j=1,...,i) mu(j). +C +C On return, the original contents of IMUK is restored. +C In the same loop the actual number of columns of VEPS is computed. +C The number of rows of VEPS is NCA. +C +C NRV = Sum(i=1,...,NBLCKS) mu(i) = NCA, +C NCV = Sum(i=1,...,NBLCKS) i*(mu(i)-nu(i)). +C + SMUI = 0 + NCV = 0 +C + DO 80 I = 1, NBLCKS + MUI = IMUK(I) + SMUI = SMUI + MUI + IMUK(I) = SMUI + NCV = NCV + I*( MUI - INUK(I) ) + 80 CONTINUE +C + NRV = NCA +C +C Computation of the matrix VEPS. +C +C Initialisation of VEPS to zero. +C + CALL DLASET( 'Full', NRV, NCV, ZERO, ZERO, VEPS, LDVEPS ) +C | I | +C Set Vii,0 = Kii in VEPS , i=1,...,NBLCKS, where Kii = |---| +C | O | +C and I is an identity matrix of size mu(i)-nu(i), +C O is a null matrix, dimensions nu(i)-by-(mu(i)-nu(i)). +C +C WR1 := Sum(j=1,...,i-1) mu(j) + 1 +C is the index of the first row in Vii,0 in VEPS. +C WC1 := Sum(j=1,...,i-1) j*(mu(j)-nu(j)) + 1 +C is the index of the first column in Vii,0 in VEPS. +C + DUMMY(1) = ONE + NUI = IMUK(1) - INUK(1) + CALL DCOPY( NUI, DUMMY, 0, VEPS, LDVEPS+1 ) + WR1 = IMUK(1) + 1 + WC1 = NUI + 1 +C + DO 100 I = 2, NBLCKS + NUI = IMUK(I) - IMUK(I-1) - INUK(I) + CALL DCOPY( NUI, DUMMY, 0, VEPS(WR1,WC1), LDVEPS+1 ) + WR1 = IMUK(I) + 1 + WC1 = WC1 + I*NUI + 100 CONTINUE +C +C Determination of the remaining nontrivial matrices in Vij,k +C block column by block column with decreasing block row index. +C +C The computation starts with the second block column since V11,0 +C has already been determined. +C The coefficients Vij,k satisfy the recurrence relation: +C +C Vij,k = Sum(r=i+1,...,j-k) AHir*Vrj,k + +C + Sum(r=i+1,...,j-k+1) EHir*Vrj,k-1, i + k < j, +C +C = EHi,i+1 * Vi+1,j,k-1 i + k = j. +C +C This recurrence relation can be derived from [1], (4.6.8) +C and formula (1) in Section PURPOSE. +C + VC1 = IMUK(1) - INUK(1) + 1 + ARI = 1 +C + DO 180 J = 2, NBLCKS + DIF = IMUK(J) - IMUK(J-1) - INUK(J) + ARI = ARI + INUK(J-1) + ARK = ARI +C +C Computation of the matrices Vij,k where i + k < j. +C Each matrix Vij,k has dimension mu(i)-by-(mu(j) - nu(j)). +C + DO 160 K = 0, J - 2 +C +C VC1, VC2 are the first and last column index of Vij,k. +C + VC2 = VC1 + DIF - 1 + AC2 = IMUK(J-K) + AR1 = ARK + ARK = ARK - INUK(J-K-1) +C + DO 120 I = J - K - 1, 1, -1 +C +C Compute the first part of Vij,k in decreasing order: +C Vij,k := Vij,k + Sum(r=i+1,..,j-k) AHir*Vrj,k. +C The non-zero parts of AHir are stored in +C A(AR1:AR1+nu(i)-1,AC1:AC2) and Vrj,k are stored in +C VEPS(AC1:AC2,VC1:VC2). +C The non-zero part of the result is stored in +C VEPS(VR1:VR2,VC1:VC2). +C + VR2 = IMUK(I) + AC1 = VR2 + 1 + VR1 = AC1 - INUK(I) + AR1 = AR1 - INUK(I) + CALL DGEMM( 'No transpose', 'No transpose', INUK(I), + $ DIF, AC2-VR2, ONE, A(AR1,AC1), LDA, + $ VEPS(AC1,VC1), LDVEPS, ONE, VEPS(VR1,VC1), + $ LDVEPS ) + 120 CONTINUE +C + ER1 = 1 +C + DO 140 I = 1, J - K - 1 +C +C Compute the second part of Vij,k+1 in normal order: +C Vij,k+1 := Sum(r=i+1,..,j-k) EHir*Vrj,k. +C The non-zero parts of EHir are stored in +C E(ER1:ER1+nu(i)-1,EC1:AC2) and Vrj,k are stored in +C VEPS(EC1:AC2,VC1:VC2). +C The non-zero part of the result is stored in +C VEPS(VR1:VR2,VC2+1:VC2+DIF), where +C DIF = VC2 - VC1 + 1 = mu(j) - nu(j). +C This code portion also computes Vij,k+1 for i + k = j. +C + VR2 = IMUK(I) + EC1 = VR2 + 1 + VR1 = EC1 - INUK(I) + CALL DGEMM( 'No transpose', 'No transpose', INUK(I), + $ DIF, AC2-VR2, ONE, E(ER1,EC1), LDE, + $ VEPS(EC1,VC1), LDVEPS, ZERO, VEPS(VR1,VC2+1), + $ LDVEPS ) + ER1 = ER1 + INUK(I) + 140 CONTINUE +C + VC1 = VC2 + 1 + 160 CONTINUE +C + VC1 = VC1 + DIF + 180 CONTINUE +C +C Restore original contents of the array IMUK. +C +C Since, at the moment: +C IMUK(i) = Sum(j=1,...,i) mu(j), (i=1,...,NBLCKS), +C the original values are: +C mu(i) = IMUK(i) - IMUK(i-1) with IMUK(0 ) = 0. +C + SMUI1 = 0 +C + DO 200 I = 1, NBLCKS + SMUI = IMUK(I) + IMUK(I) = SMUI - SMUI1 + SMUI1 = SMUI + 200 CONTINUE +C + RETURN +C *** Last line of MC03NY *** + END diff --git a/mex/sources/libslicot/MD03AD.f b/mex/sources/libslicot/MD03AD.f new file mode 100644 index 000000000..6eca057c4 --- /dev/null +++ b/mex/sources/libslicot/MD03AD.f @@ -0,0 +1,973 @@ + SUBROUTINE MD03AD( XINIT, ALG, STOR, UPLO, FCN, JPJ, M, N, ITMAX, + $ NPRINT, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, NJEV, TOL, CGTOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To minimize the sum of the squares of m nonlinear functions, e, in +C n variables, x, by a modification of the Levenberg-Marquardt +C algorithm, using either a Cholesky-based or a conjugate gradients +C solver. The user must provide a subroutine FCN which calculates +C the functions and the Jacobian J (possibly by finite differences), +C and another subroutine JPJ, which computes either J'*J + par*I +C (if ALG = 'D'), or (J'*J + par*I)*x (if ALG = 'I'), where par is +C the Levenberg factor, exploiting the possible structure of the +C Jacobian matrix. Template implementations of these routines are +C included in the SLICOT Library. +C +C ARGUMENTS +C +C Mode Parameters +C +C XINIT CHARACTER*1 +C Specifies how the variables x are initialized, as follows: +C = 'R' : the array X is initialized to random values; the +C entries DWORK(1:4) are used to initialize the +C random number generator: the first three values +C are converted to integers between 0 and 4095, and +C the last one is converted to an odd integer +C between 1 and 4095; +C = 'G' : the given entries of X are used as initial values +C of variables. +C +C ALG CHARACTER*1 +C Specifies the algorithm used for solving the linear +C systems involving a Jacobian matrix J, as follows: +C = 'D' : a direct algorithm, which computes the Cholesky +C factor of the matrix J'*J + par*I is used; +C = 'I' : an iterative Conjugate Gradients algorithm, which +C only needs the matrix J, is used. +C In both cases, matrix J is stored in a compressed form. +C +C STOR CHARACTER*1 +C If ALG = 'D', specifies the storage scheme for the +C symmetric matrix J'*J, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C The option STOR = 'F' usually ensures a faster execution. +C This parameter is not relevant if ALG = 'I'. +C +C UPLO CHARACTER*1 +C If ALG = 'D', specifies which part of the matrix J'*J +C is stored, as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C The option UPLO = 'U' usually ensures a faster execution. +C This parameter is not relevant if ALG = 'I'. +C +C Function Parameters +C +C FCN EXTERNAL +C Subroutine which evaluates the functions and the Jacobian. +C FCN must be declared in an external statement in the user +C calling program, and must have the following interface: +C +C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, +C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, JTE, +C $ DWORK, LDWORK, INFO ) +C +C where +C +C IFLAG (input/output) INTEGER +C On entry, this parameter must contain a value +C defining the computations to be performed: +C = 0 : Optionally, print the current iterate X, +C function values E, and Jacobian matrix J, +C or other results defined in terms of these +C values. See the argument NPRINT of MD03AD. +C Do not alter E and J. +C = 1 : Calculate the functions at X and return +C this vector in E. Do not alter J. +C = 2 : Calculate the Jacobian at X and return +C this matrix in J. Also return J'*e in JTE +C and NFEVL (see below). Do not alter E. +C = 3 : Do not compute neither the functions nor +C the Jacobian, but return in LDJ and +C IPAR/DPAR1,DPAR2 (some of) the integer/real +C parameters needed. +C On exit, the value of this parameter should not be +C changed by FCN unless the user wants to terminate +C execution of MD03AD, in which case IFLAG must be +C set to a negative integer. +C +C M (input) INTEGER +C The number of functions. M >= 0. +C +C N (input) INTEGER +C The number of variables. M >= N >= 0. +C +C IPAR (input/output) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix or needed for problem solving. +C IPAR is an input parameter, except for IFLAG = 3 +C on entry, when it is also an output parameter. +C On exit, if IFLAG = 3, IPAR(1) contains the length +C of the array J, for storing the Jacobian matrix, +C and the entries IPAR(2:5) contain the workspace +C required by FCN for IFLAG = 1, FCN for IFLAG = 2, +C JPJ for ALG = 'D', and JPJ for ALG = 'I', +C respectively. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 5. +C +C DPAR1 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR1,*) or (LDPAR1) +C A first set of real parameters needed for +C describing or solving the problem. +C DPAR1 can also be used as an additional array for +C intermediate results when computing the functions +C or the Jacobian. For control problems, DPAR1 could +C store the input trajectory of a system. +C +C LDPAR1 (input) INTEGER +C The leading dimension or the length of the array +C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, +C if leading dimension.) +C +C DPAR2 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR2,*) or (LDPAR2) +C A second set of real parameters needed for +C describing or solving the problem. +C DPAR2 can also be used as an additional array for +C intermediate results when computing the functions +C or the Jacobian. For control problems, DPAR2 could +C store the output trajectory of a system. +C +C LDPAR2 (input) INTEGER +C The leading dimension or the length of the array +C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, +C if leading dimension.) +C +C X (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the value of the +C variables x where the functions or the Jacobian +C must be evaluated. +C +C NFEVL (input/output) INTEGER +C The number of function evaluations needed to +C compute the Jacobian by a finite difference +C approximation. +C NFEVL is an input parameter if IFLAG = 0, or an +C output parameter if IFLAG = 2. If the Jacobian is +C computed analytically, NFEVL should be set to a +C non-positive value. +C +C E (input/output) DOUBLE PRECISION array, +C dimension (M) +C This array contains the value of the (error) +C functions e evaluated at X. +C E is an input parameter if IFLAG = 0 or 2, or an +C output parameter if IFLAG = 1. +C +C J (input/output) DOUBLE PRECISION array, dimension +C (LDJ,NC), where NC is the number of columns +C needed. +C This array contains a possibly compressed +C representation of the Jacobian matrix evaluated +C at X. If full Jacobian is stored, then NC = N. +C J is an input parameter if IFLAG = 0, or an output +C parameter if IFLAG = 2. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. LDJ >= 1. +C LDJ is essentially used inside the routines FCN +C and JPJ. +C LDJ is an input parameter, except for IFLAG = 3 +C on entry, when it is an output parameter. +C It is assumed in MD03AD that LDJ is not larger +C than needed. +C +C JTE (output) DOUBLE PRECISION array, dimension (N) +C If IFLAG = 2, the matrix-vector product J'*e. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine FCN. +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine FCN). LDWORK >= 1. +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine FCN. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO. +C INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C JPJ EXTERNAL +C Subroutine which computes J'*J + par*I, if ALG = 'D', and +C J'*J*x + par*x, if ALG = 'I', where J is the Jacobian as +C described above. +C +C JPJ must have the following interface: +C +C SUBROUTINE JPJ( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, +C $ J, LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) +C +C if ALG = 'D', and +C +C SUBROUTINE JPJ( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, +C $ INCX, DWORK, LDWORK, INFO ) +C +C if ALG = 'I', where +C +C STOR (input) CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix J'*J, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO (input) CHARACTER*1 +C Specifies which part of the matrix J'*J is stored, +C as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C N (input) INTEGER +C The number of columns of the matrix J. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C DPAR(1) must contain an initial estimate of the +C Levenberg-Marquardt parameter, par. DPAR(1) >= 0. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension +C (LDJ, NC), where NC is the number of columns. +C The leading NR-by-NC part of this array must +C contain the (compressed) representation of the +C Jacobian matrix J, where NR is the number of rows +C of J (function of IPAR entries). +C +C LDJ (input) INTEGER +C The leading dimension of array J. +C LDJ >= MAX(1,NR). +C +C JTJ (output) DOUBLE PRECISION array, +C dimension (LDJTJ,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 +C (if STOR = 'P') part of this array contains the +C upper or lower triangle of the matrix J'*J+par*I, +C depending on UPLO = 'U', or UPLO = 'L', +C respectively, stored either as a two-dimensional, +C or one-dimensional array, depending on STOR. +C +C LDJTJ (input) INTEGER +C The leading dimension of the array JTJ. +C LDJTJ >= MAX(1,N), if STOR = 'F'. +C LDJTJ >= 1, if STOR = 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine JPJ. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine JPJ). +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine JPJ. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO +C values. INFO must be zero if the subroutine +C finished successfully. +C +C If ALG = 'I', the parameters in common with those for +C ALG = 'D', have the same meaning, and the additional +C parameters are: +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, this incremented array must contain the +C vector x. +C On exit, this incremented array contains the value +C of the matrix-vector product (J'*J + par)*x. +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX > 0. +C +C Parameters marked with "(input)" must not be changed. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of functions. M >= 0. +C +C N (input) INTEGER +C The number of variables. M >= N >= 0. +C +C ITMAX (input) INTEGER +C The maximum number of iterations. ITMAX >= 0. +C +C NPRINT (input) INTEGER +C This parameter enables controlled printing of iterates if +C it is positive. In this case, FCN is called with IFLAG = 0 +C at the beginning of the first iteration and every NPRINT +C iterations thereafter and immediately prior to return, +C with X, E, and J available for printing. If NPRINT is not +C positive, no special calls of FCN with IFLAG = 0 are made. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters needed, for instance, for +C describing the structure of the Jacobian matrix, which +C are handed over to the routines FCN and JPJ. +C The first five entries of this array are modified +C internally by a call to FCN (with IFLAG = 3), but are +C restored on exit. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 5. +C +C DPAR1 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR1,*) or (LDPAR1) +C A first set of real parameters needed for describing or +C solving the problem. This argument is not used by MD03AD +C routine, but it is passed to the routine FCN. +C +C LDPAR1 (input) INTEGER +C The leading dimension or the length of the array DPAR1, as +C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading +C dimension.) +C +C DPAR2 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR2,*) or (LDPAR2) +C A second set of real parameters needed for describing or +C solving the problem. This argument is not used by MD03AD +C routine, but it is passed to the routine FCN. +C +C LDPAR2 (input) INTEGER +C The leading dimension or the length of the array DPAR2, as +C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading +C dimension.) +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if XINIT = 'G', this array must contain the +C vector of initial variables x to be optimized. +C If XINIT = 'R', this array need not be set before entry, +C and random values will be used to initialize x. +C On exit, if INFO = 0, this array contains the vector of +C values that (approximately) minimize the sum of squares of +C error functions. The values returned in IWARN and +C DWORK(1:5) give details on the iterative process. +C +C NFEV (output) INTEGER +C The number of calls to FCN with IFLAG = 1. If FCN is +C properly implemented, this includes the function +C evaluations needed for finite difference approximation +C of the Jacobian. +C +C NJEV (output) INTEGER +C The number of calls to FCN with IFLAG = 2. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If TOL >= 0, the tolerance which measures the relative +C error desired in the sum of squares. Termination occurs +C when the actual relative reduction in the sum of squares +C is at most TOL. If the user sets TOL < 0, then SQRT(EPS) +C is used instead TOL, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). +C +C CGTOL DOUBLE PRECISION +C If ALG = 'I' and CGTOL > 0, the tolerance which measures +C the relative residual of the solutions computed by the +C conjugate gradients (CG) algorithm. Termination of a +C CG process occurs when the relative residual is at +C most CGTOL. If the user sets CGTOL <= 0, then SQRT(EPS) +C is used instead CGTOL. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the residual error norm (the +C sum of squares), DWORK(3) returns the number of iterations +C performed, DWORK(4) returns the total number of conjugate +C gradients iterations performed (zero, if ALG = 'D'), and +C DWORK(5) returns the final Levenberg factor. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 5, M + 2*N + size(J) + +C max( DW( FCN|IFLAG = 1 ) + N, +C DW( FCN|IFLAG = 2 ), +C DW( sol ) ) ), +C where size(J) is the size of the Jacobian (provided by FCN +C in IPAR(1), for IFLAG = 3), DW( f ) is the workspace +C needed by the routine f, where f is FCN or JPJ (provided +C by FCN in IPAR(2:5), for IFLAG = 3), and DW( sol ) is the +C workspace needed for solving linear systems, +C DW( sol ) = N*N + DW( JPJ ), if ALG = 'D', STOR = 'F'; +C DW( sol ) = N*(N+1)/2 + DW( JPJ ), +C if ALG = 'D', STOR = 'P'; +C DW( sol ) = 3*N + DW( JPJ ), if ALG = 'I'. +C +C Warning Indicator +C +C IWARN INTEGER +C < 0: the user set IFLAG = IWARN in the subroutine FCN; +C = 0: no warning; +C = 1: if the iterative process did not converge in ITMAX +C iterations with tolerance TOL; +C = 2: if ALG = 'I', and in one or more iterations of the +C Levenberg-Marquardt algorithm, the conjugate +C gradient algorithm did not finish after 3*N +C iterations, with the accuracy required in the +C call; +C = 3: the cosine of the angle between e and any column of +C the Jacobian is at most FACTOR*EPS in absolute +C value, where FACTOR = 100 is defined in a PARAMETER +C statement; +C = 4: TOL is too small: no further reduction in the sum +C of squares is possible. +C In all these cases, DWORK(1:5) are set as described +C above. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: user-defined routine FCN returned with INFO <> 0 +C for IFLAG = 1; +C = 2: user-defined routine FCN returned with INFO <> 0 +C for IFLAG = 2; +C = 3: SLICOT Library routine MB02XD, if ALG = 'D', or +C SLICOT Library routine MB02WD, if ALG = 'I' (or +C user-defined routine JPJ), returned with INFO <> 0. +C +C METHOD +C +C If XINIT = 'R', the initial value for X is set to a vector of +C pseudo-random values uniformly distributed in [-1,1]. +C +C The Levenberg-Marquardt algorithm (described in [1]) is used for +C optimizing the parameters. This algorithm needs the Jacobian +C matrix J, which is provided by the subroutine FCN. The algorithm +C tries to update x by the formula +C +C x = x - p, +C +C using the solution of the system of linear equations +C +C (J'*J + PAR*I)*p = J'*e, +C +C where I is the identity matrix, and e the error function vector. +C The Levenberg factor PAR is decreased after each successfull step +C and increased in the other case. +C +C If ALG = 'D', a direct method, which evaluates the matrix product +C J'*J + par*I and then factors it using Cholesky algorithm, +C implemented in the SLICOT Libray routine MB02XD, is used for +C solving the linear system above. +C +C If ALG = 'I', the Conjugate Gradients method, described in [2], +C and implemented in the SLICOT Libray routine MB02WD, is used for +C solving the linear system above. The main advantage of this method +C is that in most cases the solution of the system can be computed +C in less time than the time needed to compute the matrix J'*J +C This is, however, problem dependent. +C +C REFERENCES +C +C [1] Kelley, C.T. +C Iterative Methods for Optimization. +C Society for Industrial and Applied Mathematics (SIAM), +C Philadelphia (Pa.), 1999. +C +C [2] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, +C 1996. +C +C [3] More, J.J. +C The Levenberg-Marquardt algorithm: implementation and theory. +C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in +C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg +C and New York, pp. 105-116, 1978. +C +C NUMERICAL ASPECTS +C +C The Levenberg-Marquardt algorithm described in [3] is scaling +C invariant and globally convergent to (maybe local) minima. +C According to [1], the convergence rate near a local minimum is +C quadratic, if the Jacobian is computed analytically, and linear, +C if the Jacobian is computed numerically. +C +C Whether or not the direct algorithm is faster than the iterative +C Conjugate Gradients algorithm for solving the linear systems +C involved depends on several factors, including the conditioning +C of the Jacobian matrix, and the ratio between its dimensions. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Mar. 2002. +C +C KEYWORDS +C +C Conjugate gradients, least-squares approximation, +C Levenberg-Marquardt algorithm, matrix operations, optimization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, FOUR, FIVE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, + $ FIVE = 5.0D0 ) + DOUBLE PRECISION FACTOR, MARQF, MINIMP, PARMAX + PARAMETER ( FACTOR = 10.0D0**2, MARQF = 2.0D0**2, + $ MINIMP = 2.0D0**(-3), PARMAX = 1.0D20 ) +C .. Scalar Arguments .. + CHARACTER ALG, STOR, UPLO, XINIT + INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, + $ LIPAR, M, N, NFEV, NJEV, NPRINT + DOUBLE PRECISION CGTOL, TOL +C .. Array Arguments .. + DOUBLE PRECISION DPAR1(LDPAR1,*), DPAR2(LDPAR2,*), DWORK(*), X(*) + INTEGER IPAR(*) +C .. Local Scalars .. + LOGICAL CHOL, FULL, INIT, UPPER + INTEGER DWJTJ, E, I, IFLAG, INFOL, ITER, ITERCG, IW1, + $ IW2, IWARNL, JAC, JTE, JW1, JW2, JWORK, LDJ, + $ LDW, LFCN1, LFCN2, LJTJ, LJTJD, LJTJI, NFEVL, + $ SIZEJ, WRKOPT + DOUBLE PRECISION ACTRED, BIGNUM, CGTDEF, EPSMCH, FNORM, FNORM1, + $ GNORM, GSMIN, PAR, SMLNUM, SQREPS, TOLDEF +C .. Local Arrays .. + INTEGER SEED(4) +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLABAD, DLARNV, FCN, JPJ, MB02WD, MB02XD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, MOD, SQRT +C .. +C .. Executable Statements .. +C +C Decode the scalar input parameters. +C + INIT = LSAME( XINIT, 'R' ) + CHOL = LSAME( ALG, 'D' ) + FULL = LSAME( STOR, 'F' ) + UPPER = LSAME( UPLO, 'U' ) +C +C Check the scalar input parameters. +C + IWARN = 0 + INFO = 0 + IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( CHOL .OR. LSAME( ALG, 'I' ) ) ) THEN + INFO = -2 + ELSEIF ( CHOL .AND. .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -3 + ELSEIF ( CHOL .AND. .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -4 + ELSEIF ( M.LT.0 ) THEN + INFO = -7 + ELSEIF ( N.LT.0 .OR. N.GT.M ) THEN + INFO = -8 + ELSEIF ( ITMAX.LT.0 ) THEN + INFO = -9 + ELSEIF ( LIPAR.LT.5 ) THEN + INFO = -12 + ELSEIF( LDPAR1.LT.0 ) THEN + INFO = -14 + ELSEIF( LDPAR2.LT.0 ) THEN + INFO = -16 + ELSEIF ( LDWORK.LT.5 ) THEN + INFO = -23 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MD03AD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + NFEV = 0 + NJEV = 0 + IF ( MIN( N, ITMAX ).EQ.0 ) THEN + DWORK(1) = FIVE + DWORK(2) = ZERO + DWORK(3) = ZERO + DWORK(4) = ZERO + DWORK(5) = ZERO + RETURN + ENDIF +C +C Call FCN to get the size of the array J, for storing the Jacobian +C matrix, the leading dimension LDJ and the workspace required +C by FCN for IFLAG = 1 and IFLAG = 2, and JPJ. The entries +C DWORK(1:4) should not be modified by the special call of FCN +C below, if XINIT = 'R' and the values in DWORK(1:4) are explicitly +C desired for initialization of the random number generator. +C + IFLAG = 3 + IW1 = IPAR(1) + IW2 = IPAR(2) + JW1 = IPAR(3) + JW2 = IPAR(4) + LJTJ = IPAR(5) +C + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, + $ X, NFEVL, DWORK, DWORK, LDJ, DWORK, DWORK, LDWORK, + $ INFOL ) +C + SIZEJ = IPAR(1) + LFCN1 = IPAR(2) + LFCN2 = IPAR(3) + LJTJD = IPAR(4) + LJTJI = IPAR(5) +C + IPAR(1) = IW1 + IPAR(2) = IW2 + IPAR(3) = JW1 + IPAR(4) = JW2 + IPAR(5) = LJTJ +C +C Define pointers to the array variables stored in DWORK. +C + JAC = 1 + E = JAC + SIZEJ + JTE = E + M + IW1 = JTE + N + IW2 = IW1 + N + JW1 = IW2 + JW2 = IW2 + N +C +C Check the workspace length. +C + JWORK = JW1 + IF ( CHOL ) THEN + IF ( FULL ) THEN + LDW = N*N + ELSE + LDW = ( N*( N + 1 ) ) / 2 + ENDIF + DWJTJ = JWORK + JWORK = DWJTJ + LDW + LJTJ = LJTJD + ELSE + LDW = 3*N + LJTJ = LJTJI + ENDIF + IF ( LDWORK.LT.MAX( 5, SIZEJ + M + 2*N + + $ MAX( LFCN1 + N, LFCN2, LDW + LJTJ ) ) ) + $ THEN + INFO = -23 + ENDIF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MD03AD', -INFO ) + RETURN + ENDIF +C +C Set default tolerances. SQREPS is the square root of the machine +C precision, and GSMIN is used in the tests of the gradient norm. +C + EPSMCH = DLAMCH( 'Epsilon' ) + SQREPS = SQRT( EPSMCH ) + TOLDEF = TOL + IF ( TOLDEF.LT.ZERO ) + $ TOLDEF = SQREPS + CGTDEF = CGTOL + IF ( CGTDEF.LE.ZERO ) + $ CGTDEF = SQREPS + GSMIN = FACTOR*EPSMCH + WRKOPT = 5 +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Initialization. +C + IF ( INIT ) THEN +C +C SEED is the initial state of the random number generator. +C SEED(4) must be odd. +C + SEED(1) = MOD( INT( DWORK(1) ), 4096 ) + SEED(2) = MOD( INT( DWORK(2) ), 4096 ) + SEED(3) = MOD( INT( DWORK(3) ), 4096 ) + SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) + CALL DLARNV( 2, SEED, N, X ) + ENDIF +C +C Evaluate the function at the starting point and calculate +C its norm. +C Workspace: need: SIZEJ + M + 2*N + LFCN1; +C prefer: larger. +C + IFLAG = 1 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, + $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JTE), + $ DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) + NFEV = 1 + FNORM = DNRM2( M, DWORK(E), 1 ) + ACTRED = ZERO + ITERCG = 0 + ITER = 0 + IWARNL = 0 + PAR = ZERO + IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) + $ GO TO 40 +C +C Set the initial vector for the conjugate gradients algorithm. +C + DWORK(IW1) = ZERO + CALL DCOPY( N, DWORK(IW1), 0, DWORK(IW1), 1 ) +C +C WHILE ( nonconvergence and ITER < ITMAX ) DO +C +C Beginning of the outer loop. +C + 10 CONTINUE +C +C Calculate the Jacobian matrix. +C Workspace: need: SIZEJ + M + 2*N + LFCN2; +C prefer: larger. +C + ITER = ITER + 1 + IFLAG = 2 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Compute the gradient norm. +C + GNORM = DNRM2( N, DWORK(JTE), 1 ) + IF ( NFEVL.GT.0 ) + $ NFEV = NFEV + NFEVL + NJEV = NJEV + 1 + IF ( GNORM.LE.GSMIN ) + $ IWARN = 3 + IF ( IWARN.NE.0 ) + $ GO TO 40 + IF ( ITER.EQ.1 ) THEN + WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) + PAR = MIN( GNORM, SQRT( PARMAX ) ) + END IF + IF ( IFLAG.LT.0 ) + $ GO TO 40 +C +C If requested, call FCN to enable printing of iterates. +C + IF ( NPRINT.GT.0 ) THEN + IFLAG = 0 + IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( IFLAG.LT.0 ) + $ GO TO 40 + END IF + END IF +C +C Beginning of the inner loop. +C + 20 CONTINUE +C +C Store the Levenberg factor in DWORK(E) (which is no longer +C needed), to pass it to JPJ routine. +C + DWORK(E) = PAR +C +C Solve (J'*J + PAR*I)*x = J'*e, and store x in DWORK(IW1). +C Additional workspace: +C N*N + DW(JPJ), if ALG = 'D', STOR = 'F'; +C N*( N + 1)/2 + DW(JPJ), if ALG = 'D', STOR = 'P'; +C 3*N + DW(JPJ), if ALG = 'I'. +C + IF ( CHOL ) THEN + CALL DCOPY( N, DWORK(JTE), 1, DWORK(IW1), 1 ) + CALL MB02XD( 'Function', STOR, UPLO, JPJ, M, N, 1, IPAR, + $ LIPAR, DWORK(E), 1, DWORK(JAC), LDJ, + $ DWORK(IW1), N, DWORK(DWJTJ), N, + $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) + ELSE + CALL MB02WD( 'Function', JPJ, N, IPAR, LIPAR, DWORK(E), + $ 1, 3*N, DWORK(JAC), LDJ, DWORK(JTE), 1, + $ DWORK(IW1), 1, CGTOL*GNORM, DWORK(JWORK), + $ LDWORK-JWORK+1, IWARN, INFOL ) + ITERCG = ITERCG + INT( DWORK(JWORK) ) + IWARNL = MAX( 2*IWARN, IWARNL ) + ENDIF +C + IF ( INFOL.NE.0 ) THEN + INFO = 3 + RETURN + ENDIF +C +C Compute updated X. +C + DO 30 I = 0, N - 1 + DWORK(IW2+I) = X(I+1) - DWORK(IW1+I) + 30 CONTINUE +C +C Evaluate the function at x - p and calculate its norm. +C Workspace: need: SIZEJ + M + 3*N + LFCN1; +C prefer: larger. +C + IFLAG = 1 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, DWORK(IW2), NFEVL, DWORK(E), DWORK(JAC), + $ LDJ, DWORK(JTE), DWORK(JW2), LDWORK-JW2+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + NFEV = NFEV + 1 + IF ( IFLAG.LT.0 ) + $ GO TO 40 + FNORM1 = DNRM2( M, DWORK(E), 1 ) +C +C Now, check whether this step was successful and update the +C Levenberg factor. +C + IF ( FNORM.LT.FNORM1 ) THEN +C +C Unsuccessful step: increase PAR. +C + ACTRED = ONE + IF ( PAR.GT.PARMAX ) THEN + IF ( PAR/MARQF.LE.BIGNUM ) + $ PAR = PAR*MARQF + ELSE + PAR = PAR*MARQF + END IF +C + ELSE +C +C Successful step: update PAR, X, and FNORM. +C + ACTRED = ONE - ( FNORM1/FNORM )**2 + IF ( ( FNORM - FNORM1 )*( FNORM + FNORM1 ) .LT. + $ MINIMP*DDOT( N, DWORK(IW1), 1, + $ DWORK(JTE), 1 ) ) THEN + IF ( PAR.GT.PARMAX ) THEN + IF ( PAR/MARQF.LE.BIGNUM ) + $ PAR = PAR*MARQF + ELSE + PAR = PAR*MARQF + END IF + ELSE + PAR = MAX( PAR/MARQF, SMLNUM ) + ENDIF + CALL DCOPY( N, DWORK(IW2), 1, X, 1 ) + FNORM = FNORM1 + ENDIF +C + IF ( ( ACTRED.LE.TOLDEF ) .OR. ( ITER.GT.ITMAX ) .OR. + $ ( PAR.GT.PARMAX ) ) + $ GO TO 40 + IF ( ACTRED.LE.EPSMCH ) THEN + IWARN = 4 + GO TO 40 + ENDIF +C +C End of the inner loop. Repeat if unsuccessful iteration. +C + IF ( FNORM.LT.FNORM1 ) + $ GO TO 20 +C +C End of the outer loop. +C + GO TO 10 +C +C END WHILE 10 +C + 40 CONTINUE +C +C Termination, either normal or user imposed. +C + IF ( ACTRED.GT.TOLDEF ) + $ IWARN = 1 + IF ( IWARNL.NE.0 ) + $ IWARN = 2 +C + IF ( IFLAG.LT.0 ) + $ IWARN = IFLAG + IF ( NPRINT.GT.0 ) THEN + IFLAG = 0 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JTE), DWORK(JW1), LDWORK-JW1+1, INFOL ) + IF ( IFLAG.LT.0 ) + $ IWARN = IFLAG + END IF +C + DWORK(1) = WRKOPT + DWORK(2) = FNORM + DWORK(3) = ITER + DWORK(4) = ITERCG + DWORK(5) = PAR +C + RETURN +C *** Last line of MD03AD *** + END diff --git a/mex/sources/libslicot/MD03BA.f b/mex/sources/libslicot/MD03BA.f new file mode 100644 index 000000000..ac2782e3a --- /dev/null +++ b/mex/sources/libslicot/MD03BA.f @@ -0,0 +1,151 @@ + SUBROUTINE MD03BA( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, + $ GNORM, IPVT, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the QR factorization with column pivoting of an +C m-by-n Jacobian matrix J (m >= n), that is, J*P = Q*R, where Q is +C a matrix with orthogonal columns, P a permutation matrix, and +C R an upper trapezoidal matrix with diagonal elements of +C nonincreasing magnitude, and to apply the transformation Q' on +C the error vector e (in-situ). The 1-norm of the scaled gradient +C is also returned. +C +C This routine is an interface to SLICOT Library routine MD03BX, +C for solving standard nonlinear least squares problems using SLICOT +C routine MD03BD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain the number of rows M of the Jacobian +C matrix J. M >= N. +C IPAR is provided for compatibility with SLICOT Library +C routine MD03BD. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 1. +C +C FNORM (input) DOUBLE PRECISION +C The Euclidean norm of the vector e. FNORM >= 0. +C +C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) +C On entry, the leading M-by-N part of this array must +C contain the Jacobian matrix J. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular factor R of the +C Jacobian matrix. Note that for efficiency of the later +C calculations, the matrix R is delivered with the leading +C dimension MAX(1,N), possibly much smaller than the value +C of LDJ on entry. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. +C On entry, LDJ >= MAX(1,M). +C On exit, LDJ >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the error vector e. +C On exit, this array contains the updated vector Q'*e. +C +C JNORMS (output) DOUBLE PRECISION array, dimension (N) +C This array contains the Euclidean norms of the columns +C of the Jacobian matrix, considered in the initial order. +C +C GNORM (output) DOUBLE PRECISION +C If FNORM > 0, the 1-norm of the scaled vector +C J'*Q'*e/FNORM, with each element i further divided +C by JNORMS(i) (if JNORMS(i) is nonzero). +C If FNORM = 0, the returned value of GNORM is 0. +C +C IPVT (output) INTEGER array, dimension (N) +C This array defines the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1, if N = 0 or M = 1; +C LDWORK >= 4*N+1, if N > 1. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine calls SLICOT Library routine MD03BX to perform the +C calculations. +C +C FURTHER COMMENTS +C +C For efficiency, the arguments are not checked. This is done in +C the routine MD03BX (except for LIPAR). +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, Jacobian matrix, matrix algebra, +C matrix operations. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, LDJ, LDWORK, LIPAR, N + DOUBLE PRECISION FNORM, GNORM +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*) + DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) +C .. External Subroutines .. + EXTERNAL MD03BX +C .. +C .. Executable Statements .. +C + CALL MD03BX( IPAR(1), N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, + $ DWORK, LDWORK, INFO ) + RETURN +C +C *** Last line of MD03BA *** + END diff --git a/mex/sources/libslicot/MD03BB.f b/mex/sources/libslicot/MD03BB.f new file mode 100644 index 000000000..67772e407 --- /dev/null +++ b/mex/sources/libslicot/MD03BB.f @@ -0,0 +1,203 @@ + SUBROUTINE MD03BB( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, + $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a value for the parameter PAR such that if x solves +C the system +C +C A*x = b , sqrt(PAR)*D*x = 0 , +C +C in the least squares sense, where A is an m-by-n matrix, D is an +C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if +C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, +C then either PAR is zero and +C +C ( DXNORM - DELTA ) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . +C +C It is assumed that a QR factorization, with column pivoting, of A +C is available, that is, A*P = Q*R, where P is a permutation matrix, +C Q has orthogonal columns, and R is an upper triangular matrix +C with diagonal elements of nonincreasing magnitude. +C The routine needs the full upper triangle of R, the permutation +C matrix P, and the first n components of Q'*b (' denotes the +C transpose). On output, MD03BB also provides an upper triangular +C matrix S such that +C +C P'*(A'*A + PAR*D*D)*P = S'*S . +C +C Matrix S is used in the solution process. +C +C This routine is an interface to SLICOT Library routine MD03BY, +C for solving standard nonlinear least squares problems using SLICOT +C routine MD03BD. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the matrices R and S +C should be estimated, as follows: +C = 'E' : use incremental condition estimation for R and S; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of R and S for zero values; +C = 'U' : use the rank already stored in RANKS (for R). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix R. IPAR and LIPAR are not used by this routine, +C but are provided for compatibility with SLICOT Library +C routine MD03BD. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the full upper triangle is unaltered, and the +C strict lower triangle contains the strict upper triangle +C (transposed) of the upper triangular matrix S. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C A*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. DIAG(I) <> 0, I = 1,...,N. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C DELTA (input) DOUBLE PRECISION +C An upper bound on the Euclidean norm of D*x. DELTA > 0. +C +C PAR (input/output) DOUBLE PRECISION +C On entry, PAR must contain an initial estimate of the +C Levenberg-Marquardt parameter. PAR >= 0. +C On exit, it contains the final estimate of this parameter. +C +C RANKS (input or output) INTEGER array, dimension (1) +C On entry, if COND = 'U' and N > 0, this array must contain +C the numerical rank of the matrix R. +C On exit, this array contains the numerical rank of the +C matrix S. +C RANKS is defined as an array for compatibility with SLICOT +C Library routine MD03BD. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system A*x = b, sqrt(PAR)*D*x = 0. +C +C RX (output) DOUBLE PRECISION array, dimension (N) +C This array contains the matrix-vector product -R*P'*x. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C rank of the matrices R and S. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C the reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 4*N, if COND = 'E'; +C LDWORK >= 2*N, if COND <> 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C This routine calls SLICOT Library routine MD03BY to perform the +C calculations. +C +C FURTHER COMMENTS +C +C For efficiency, the arguments are not checked. This is done in +C the routine MD03BY (except for LIPAR). +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, LIPAR, N + DOUBLE PRECISION DELTA, PAR, TOL +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*), RANKS(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) +C .. External Subroutines .. + EXTERNAL MD03BY +C .. +C .. Executable Statements .. +C + CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, + $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) + RETURN +C +C *** Last line of MD03BB *** + END diff --git a/mex/sources/libslicot/MD03BD.f b/mex/sources/libslicot/MD03BD.f new file mode 100644 index 000000000..eccd179e7 --- /dev/null +++ b/mex/sources/libslicot/MD03BD.f @@ -0,0 +1,1206 @@ + SUBROUTINE MD03BD( XINIT, SCALE, COND, FCN, QRFACT, LMPARM, M, N, + $ ITMAX, FACTOR, NPRINT, IPAR, LIPAR, DPAR1, + $ LDPAR1, DPAR2, LDPAR2, X, DIAG, NFEV, NJEV, + $ FTOL, XTOL, GTOL, TOL, IWORK, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To minimize the sum of the squares of m nonlinear functions, e, in +C n variables, x, by a modification of the Levenberg-Marquardt +C algorithm. The user must provide a subroutine FCN which calculates +C the functions and the Jacobian (possibly by finite differences). +C In addition, specialized subroutines QRFACT, for QR factorization +C with pivoting of the Jacobian, and LMPARM, for the computation of +C Levenberg-Marquardt parameter, exploiting the possible structure +C of the Jacobian matrix, should be provided. Template +C implementations of these routines are included in SLICOT Library. +C +C ARGUMENTS +C +C Mode Parameters +C +C XINIT CHARACTER*1 +C Specifies how the variables x are initialized, as follows: +C = 'R' : the array X is initialized to random values; the +C entries DWORK(1:4) are used to initialize the +C random number generator: the first three values +C are converted to integers between 0 and 4095, and +C the last one is converted to an odd integer +C between 1 and 4095; +C = 'G' : the given entries of X are used as initial values +C of variables. +C +C SCALE CHARACTER*1 +C Specifies how the variables will be scaled, as follows: +C = 'I' : use internal scaling; +C = 'S' : use specified scaling factors, given in DIAG. +C +C COND CHARACTER*1 +C Specifies whether the condition of the linear systems +C involved should be estimated, as follows: +C = 'E' : use incremental condition estimation to find the +C numerical rank; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of matrices for zero values. +C +C Function Parameters +C +C FCN EXTERNAL +C Subroutine which evaluates the functions and the Jacobian. +C FCN must be declared in an external statement in the user +C calling program, and must have the following interface: +C +C SUBROUTINE FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, +C $ DPAR2, LDPAR2, X, NFEVL, E, J, LDJ, DWORK, +C $ LDWORK, INFO ) +C +C where +C +C IFLAG (input/output) INTEGER +C On entry, this parameter must contain a value +C defining the computations to be performed: +C = 0 : Optionally, print the current iterate X, +C function values E, and Jacobian matrix J, +C or other results defined in terms of these +C values. See the argument NPRINT of MD03BD. +C Do not alter E and J. +C = 1 : Calculate the functions at X and return +C this vector in E. Do not alter J. +C = 2 : Calculate the Jacobian at X and return +C this matrix in J. Also return NFEVL +C (see below). Do not alter E. +C = 3 : Do not compute neither the functions nor +C the Jacobian, but return in LDJ and +C IPAR/DPAR1,DPAR2 (some of) the integer/real +C parameters needed. +C On exit, the value of this parameter should not be +C changed by FCN unless the user wants to terminate +C execution of MD03BD, in which case IFLAG must be +C set to a negative integer. +C +C M (input) INTEGER +C The number of functions. M >= 0. +C +C N (input) INTEGER +C The number of variables. M >= N >= 0. +C +C IPAR (input/output) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix or needed for problem solving. +C IPAR is an input parameter, except for IFLAG = 3 +C on entry, when it is also an output parameter. +C On exit, if IFLAG = 3, IPAR(1) contains the length +C of the array J, for storing the Jacobian matrix, +C and the entries IPAR(2:5) contain the workspace +C required by FCN for IFLAG = 1, FCN for IFLAG = 2, +C QRFACT, and LMPARM, respectively. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 5. +C +C DPAR1 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR1,*) or (LDPAR1) +C A first set of real parameters needed for +C describing or solving the problem. +C DPAR1 can also be used as an additional array for +C intermediate results when computing the functions +C or the Jacobian. For control problems, DPAR1 could +C store the input trajectory of a system. +C +C LDPAR1 (input) INTEGER +C The leading dimension or the length of the array +C DPAR1, as convenient. LDPAR1 >= 0. (LDPAR1 >= 1, +C if leading dimension.) +C +C DPAR2 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR2,*) or (LDPAR2) +C A second set of real parameters needed for +C describing or solving the problem. +C DPAR2 can also be used as an additional array for +C intermediate results when computing the functions +C or the Jacobian. For control problems, DPAR2 could +C store the output trajectory of a system. +C +C LDPAR2 (input) INTEGER +C The leading dimension or the length of the array +C DPAR2, as convenient. LDPAR2 >= 0. (LDPAR2 >= 1, +C if leading dimension.) +C +C X (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the value of the +C variables x where the functions or the Jacobian +C must be evaluated. +C +C NFEVL (input/output) INTEGER +C The number of function evaluations needed to +C compute the Jacobian by a finite difference +C approximation. +C NFEVL is an input parameter if IFLAG = 0, or an +C output parameter if IFLAG = 2. If the Jacobian is +C computed analytically, NFEVL should be set to a +C non-positive value. +C +C E (input/output) DOUBLE PRECISION array, +C dimension (M) +C This array contains the value of the (error) +C functions e evaluated at X. +C E is an input parameter if IFLAG = 0 or 2, or an +C output parameter if IFLAG = 1. +C +C J (input/output) DOUBLE PRECISION array, dimension +C (LDJ,NC), where NC is the number of columns +C needed. +C This array contains a possibly compressed +C representation of the Jacobian matrix evaluated +C at X. If full Jacobian is stored, then NC = N. +C J is an input parameter if IFLAG = 0, or an output +C parameter if IFLAG = 2. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. LDJ >= 1. +C LDJ is essentially used inside the routines FCN, +C QRFACT and LMPARM. +C LDJ is an input parameter, except for IFLAG = 3 +C on entry, when it is an output parameter. +C It is assumed in MD03BD that LDJ is not larger +C than needed. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine FCN. +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine FCN). LDWORK >= 1. +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine FCN. The LAPACK Library routine XERBLA +C should be used in conjunction with negative INFO. +C INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C QRFACT EXTERNAL +C Subroutine which computes the QR factorization with +C (block) column pivoting of the Jacobian matrix, J*P = Q*R. +C QRFACT must be declared in an external statement in the +C calling program, and must have the following interface: +C +C SUBROUTINE QRFACT( N, IPAR, LIPAR, FNORM, J, LDJ, E, +C $ JNORMS, GNORM, IPVT, DWORK, LDWORK, +C $ INFO ) +C +C where +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. +C N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C FNORM (input) DOUBLE PRECISION +C The Euclidean norm of the vector e. FNORM >= 0. +C +C J (input/output) DOUBLE PRECISION array, dimension +C (LDJ, NC), where NC is the number of columns. +C On entry, the leading NR-by-NC part of this array +C must contain the (compressed) representation +C of the Jacobian matrix J, where NR is the number +C of rows of J (function of IPAR entries). +C On exit, the leading N-by-NC part of this array +C contains a (compressed) representation of the +C upper triangular factor R of the Jacobian matrix. +C For efficiency of the later calculations, the +C matrix R is delivered with the leading dimension +C MAX(1,N), possibly much smaller than the value +C of LDJ on entry. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. +C On entry, LDJ >= MAX(1,NR). +C On exit, LDJ >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension +C (NR) +C On entry, this array contains the error vector e. +C On exit, this array contains the updated vector +C Z*Q'*e, where Z is a block row permutation matrix +C (possibly identity) used in the QR factorization +C of J. (See, for example, the SLICOT Library +C routine NF01BS, Section METHOD.) +C +C JNORMS (output) DOUBLE PRECISION array, dimension (N) +C This array contains the Euclidean norms of the +C columns of the Jacobian matrix (in the original +C order). +C +C GNORM (output) DOUBLE PRECISION +C If FNORM > 0, the 1-norm of the scaled vector +C J'*e/FNORM, with each element i further divided +C by JNORMS(i) (if JNORMS(i) is nonzero). +C If FNORM = 0, the returned value of GNORM is 0. +C +C IPVT (output) INTEGER array, dimension (N) +C This array defines the permutation matrix P such +C that J*P = Q*R. Column j of P is column IPVT(j) of +C the identity matrix. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine QRFACT. +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine QRFACT). LDWORK >= 1. +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine QRFACT. The LAPACK Library routine +C XERBLA should be used in conjunction with negative +C INFO. INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C LMPARM EXTERNAL +C Subroutine which determines a value for the Levenberg- +C Marquardt parameter PAR such that if x solves the system +C +C J*x = b , sqrt(PAR)*D*x = 0 , +C +C in the least squares sense, where J is an m-by-n matrix, +C D is an n-by-n nonsingular diagonal matrix, and b is an +C m-vector, and if DELTA is a positive number, DXNORM is +C the Euclidean norm of D*x, then either PAR is zero and +C +C ( DXNORM - DELTA ) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . +C +C It is assumed that a block QR factorization, with column +C pivoting, of J is available, that is, J*P = Q*R, where P +C is a permutation matrix, Q has orthogonal columns, and +C R is an upper triangular matrix (possibly stored in a +C compressed form), with diagonal elements of nonincreasing +C magnitude for each block. On output, LMPARM also provides +C a (compressed) representation of an upper triangular +C matrix S, such that +C +C P'*(J'*J + PAR*D*D)*P = S'*S . +C +C LMPARM must be declared in an external statement in the +C calling program, and must have the following interface: +C +C SUBROUTINE LMPARM( COND, N, IPAR, LIPAR, R, LDR, IPVT, +C $ DIAG, QTB, DELTA, PAR, RANKS, X, RX, +C $ TOL, DWORK, LDWORK, INFO ) +C +C where +C +C COND CHARACTER*1 +C Specifies whether the condition of the linear +C systems involved should be estimated, as follows: +C = 'E' : use incremental condition estimation +C to find the numerical rank; +C = 'N' : do not use condition estimation, but +C check the diagonal entries for zero +C values; +C = 'U' : use the ranks already stored in RANKS +C (for R). +C +C N (input) INTEGER +C The order of the matrix R. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of +C the Jacobian matrix. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension +C (LDR, NC), where NC is the number of columns. +C On entry, the leading N-by-NC part of this array +C must contain the (compressed) representation (Rc) +C of the upper triangular matrix R. +C On exit, the full upper triangular part of R +C (in representation Rc), is unaltered, and the +C remaining part contains (part of) the (compressed) +C representation of the transpose of the upper +C triangular matrix S. +C +C LDR (input) INTEGER +C The leading dimension of array R. +C LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P +C such that J*P = Q*R. Column j of P is column +C IPVT(j) of the identity matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of +C the matrix D. DIAG(I) <> 0, I = 1,...,N. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of +C the vector Q'*b. +C +C DELTA (input) DOUBLE PRECISION +C An upper bound on the Euclidean norm of D*x. +C DELTA > 0. +C +C PAR (input/output) DOUBLE PRECISION +C On entry, PAR must contain an initial estimate of +C the Levenberg-Marquardt parameter. PAR >= 0. +C On exit, it contains the final estimate of this +C parameter. +C +C RANKS (input or output) INTEGER array, dimension (r), +C where r is the number of diagonal blocks R_k in R, +C corresponding to the block column structure of J. +C On entry, if COND = 'U' and N > 0, this array must +C contain the numerical ranks of the submatrices +C R_k, k = 1:r. The number r is defined in terms of +C the entries of IPAR. +C On exit, if N > 0, this array contains the +C numerical ranks of the submatrices S_k, k = 1:r. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of +C the system J*x = b, sqrt(PAR)*D*x = 0. +C +C RX (output) DOUBLE PRECISION array, dimension (N) +C This array contains the matrix-vector product +C -R*P'*x. +C +C TOL (input) DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for +C finding the ranks of the submatrices R_k and S_k. +C If the user sets TOL > 0, then the given value of +C TOL is used as a lower bound for the reciprocal +C condition number; a (sub)matrix whose estimated +C condition number is less than 1/TOL is considered +C to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, +C defined by TOLDEF = N*EPS, is used instead, +C where EPS is the machine precision (see LAPACK +C Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' +C or 'N'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C The workspace array for subroutine LMPARM. +C On exit, if INFO = 0, DWORK(1) returns the optimal +C value of LDWORK. +C +C LDWORK (input) INTEGER +C The size of the array DWORK (as large as needed +C in the subroutine LMPARM). LDWORK >= 1. +C +C INFO INTEGER +C Error indicator, set to a negative value if an +C input (scalar) argument is erroneous, and to +C positive values for other possible errors in the +C subroutine LMPARM. The LAPACK Library routine +C XERBLA should be used in conjunction with negative +C INFO. INFO must be zero if the subroutine finished +C successfully. +C +C Parameters marked with "(input)" must not be changed. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of functions. M >= 0. +C +C N (input) INTEGER +C The number of variables. M >= N >= 0. +C +C ITMAX (input) INTEGER +C The maximum number of iterations. ITMAX >= 0. +C +C FACTOR (input) DOUBLE PRECISION +C The value used in determining the initial step bound. This +C bound is set to the product of FACTOR and the Euclidean +C norm of DIAG*X if nonzero, or else to FACTOR itself. +C In most cases FACTOR should lie in the interval (.1,100). +C A generally recommended value is 100. FACTOR > 0. +C +C NPRINT (input) INTEGER +C This parameter enables controlled printing of iterates if +C it is positive. In this case, FCN is called with IFLAG = 0 +C at the beginning of the first iteration and every NPRINT +C iterations thereafter and immediately prior to return, +C with X, E, and J available for printing. Note that when +C called immediately prior to return, J normally contains +C the result returned by QRFACT and LMPARM (the compressed +C R and S factors). If NPRINT is not positive, no special +C calls of FCN with IFLAG = 0 are made. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters needed, for instance, for +C describing the structure of the Jacobian matrix, which +C are handed over to the routines FCN, QRFACT and LMPARM. +C The first five entries of this array are modified +C internally by a call to FCN (with IFLAG = 3), but are +C restored on exit. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 5. +C +C DPAR1 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR1,*) or (LDPAR1) +C A first set of real parameters needed for describing or +C solving the problem. This argument is not used by MD03BD +C routine, but it is passed to the routine FCN. +C +C LDPAR1 (input) INTEGER +C The leading dimension or the length of the array DPAR1, as +C convenient. LDPAR1 >= 0. (LDPAR1 >= 1, if leading +C dimension.) +C +C DPAR2 (input/output) DOUBLE PRECISION array, dimension +C (LDPAR2,*) or (LDPAR2) +C A second set of real parameters needed for describing or +C solving the problem. This argument is not used by MD03BD +C routine, but it is passed to the routine FCN. +C +C LDPAR2 (input) INTEGER +C The leading dimension or the length of the array DPAR2, as +C convenient. LDPAR2 >= 0. (LDPAR2 >= 1, if leading +C dimension.) +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if XINIT = 'G', this array must contain the +C vector of initial variables x to be optimized. +C If XINIT = 'R', this array need not be set before entry, +C and random values will be used to initialize x. +C On exit, if INFO = 0, this array contains the vector of +C values that (approximately) minimize the sum of squares of +C error functions. The values returned in IWARN and +C DWORK(1:4) give details on the iterative process. +C +C DIAG (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if SCALE = 'S', this array must contain some +C positive entries that serve as multiplicative scale +C factors for the variables x. DIAG(I) > 0, I = 1,...,N. +C If SCALE = 'I', DIAG is internally set. +C On exit, this array contains the scale factors used +C (or finally used, if SCALE = 'I'). +C +C NFEV (output) INTEGER +C The number of calls to FCN with IFLAG = 1. If FCN is +C properly implemented, this includes the function +C evaluations needed for finite difference approximation +C of the Jacobian. +C +C NJEV (output) INTEGER +C The number of calls to FCN with IFLAG = 2. +C +C Tolerances +C +C FTOL DOUBLE PRECISION +C If FTOL >= 0, the tolerance which measures the relative +C error desired in the sum of squares. Termination occurs +C when both the actual and predicted relative reductions in +C the sum of squares are at most FTOL. If the user sets +C FTOL < 0, then SQRT(EPS) is used instead FTOL, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C +C XTOL DOUBLE PRECISION +C If XTOL >= 0, the tolerance which measures the relative +C error desired in the approximate solution. Termination +C occurs when the relative error between two consecutive +C iterates is at most XTOL. If the user sets XTOL < 0, +C then SQRT(EPS) is used instead XTOL. +C +C GTOL DOUBLE PRECISION +C If GTOL >= 0, the tolerance which measures the +C orthogonality desired between the function vector e and +C the columns of the Jacobian J. Termination occurs when +C the cosine of the angle between e and any column of the +C Jacobian J is at most GTOL in absolute value. If the user +C sets GTOL < 0, then EPS is used instead GTOL. +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C ranks of the matrices of linear systems to be solved. If +C the user sets TOL > 0, then the given value of TOL is used +C as a lower bound for the reciprocal condition number; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*EPS, is used instead. +C This parameter is not relevant if COND = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+r), where r is the number +C of diagonal blocks R_k in R (see description of LMPARM). +C On output, if INFO = 0, the first N entries of this array +C define a permutation matrix P such that J*P = Q*R, where +C J is the final calculated Jacobian, Q is an orthogonal +C matrix (not stored), and R is upper triangular with +C diagonal elements of nonincreasing magnitude (possibly +C for each block column of J). Column j of P is column +C IWORK(j) of the identity matrix. If INFO = 0, the entries +C N+1:N+r of this array contain the ranks of the final +C submatrices S_k (see description of LMPARM). +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the residual error norm (the +C sum of squares), DWORK(3) returns the number of iterations +C performed, and DWORK(4) returns the final Levenberg +C factor. If INFO = 0, N > 0, and IWARN >= 0, the elements +C DWORK(5) to DWORK(4+M) contain the final matrix-vector +C product Z*Q'*e, and the elements DWORK(5+M) to +C DWORK(4+M+N*NC) contain the (compressed) representation of +C final upper triangular matrices R and S (if IWARN <> 4). +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max( 4, M + max( size(J) + +C max( DW( FCN|IFLAG = 1 ), +C DW( FCN|IFLAG = 2 ), +C DW( QRFACT ) + N ), +C N*NC + N + +C max( M + DW( FCN|IFLAG = 1 ), +C N + DW( LMPARM ) ) ) ), +C where size(J) is the size of the Jacobian (provided by FCN +C in IPAR(1), for IFLAG = 3), and DW( f ) is the workspace +C needed by the routine f, where f is FCN, QRFACT, or LMPARM +C (provided by FCN in IPAR(2:5), for IFLAG = 3). +C +C Warning Indicator +C +C IWARN INTEGER +C < 0: the user set IFLAG = IWARN in the subroutine FCN; +C = 1: both actual and predicted relative reductions in +C the sum of squares are at most FTOL; +C = 2: relative error between two consecutive iterates is +C at most XTOL; +C = 3: conditions for IWARN = 1 and IWARN = 2 both hold; +C = 4: the cosine of the angle between e and any column of +C the Jacobian is at most GTOL in absolute value; +C = 5: the number of iterations has reached ITMAX without +C satisfying any convergence condition; +C = 6: FTOL is too small: no further reduction in the sum +C of squares is possible; +C = 7: XTOL is too small: no further improvement in the +C approximate solution x is possible; +C = 8: GTOL is too small: e is orthogonal to the columns of +C the Jacobian to machine precision. +C In all these cases, DWORK(1:4) are set as described above. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: user-defined routine FCN returned with INFO <> 0 +C for IFLAG = 1; +C = 2: user-defined routine FCN returned with INFO <> 0 +C for IFLAG = 2; +C = 3: user-defined routine QRFACT returned with INFO <> 0; +C = 4: user-defined routine LMPARM returned with INFO <> 0. +C +C METHOD +C +C If XINIT = 'R', the initial value for x is set to a vector of +C pseudo-random values uniformly distributed in (-1,1). +C +C The Levenberg-Marquardt algorithm (described in [1,3]) is used for +C optimizing the variables x. This algorithm needs the Jacobian +C matrix J, which is provided by the subroutine FCN. A trust region +C method is used. The algorithm tries to update x by the formula +C +C x = x - p, +C +C using an approximate solution of the system of linear equations +C +C (J'*J + PAR*D*D)*p = J'*e, +C +C with e the error function vector, and D a diagonal nonsingular +C matrix, where either PAR = 0 and +C +C ( norm( D*x ) - DELTA ) <= 0.1*DELTA , +C +C or PAR > 0 and +C +C ABS( norm( D*x ) - DELTA ) <= 0.1*DELTA . +C +C DELTA is the radius of the trust region. If the Gauss-Newton +C direction is not acceptable, then an iterative algorithm obtains +C improved lower and upper bounds for the Levenberg-Marquardt +C parameter PAR. Only a few iterations are generally needed for +C convergence of the algorithm. The trust region radius DELTA +C and the Levenberg factor PAR are updated based on the ratio +C between the actual and predicted reduction in the sum of squares. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C [2] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, pp. 520-528, +C 1996. +C +C [3] More, J.J. +C The Levenberg-Marquardt algorithm: implementation and theory. +C In Watson, G.A. (Ed.), Numerical Analysis, Lecture Notes in +C Mathematics, vol. 630, Springer-Verlag, Berlin, Heidelberg +C and New York, pp. 105-116, 1978. +C +C NUMERICAL ASPECTS +C +C The Levenberg-Marquardt algorithm described in [3] is scaling +C invariant and globally convergent to (maybe local) minima. +C The convergence rate near a local minimum is quadratic, if the +C Jacobian is computed analytically, and linear, if the Jacobian +C is computed numerically. +C +C FURTHER COMMENTS +C +C This routine is a more general version of the subroutines LMDER +C and LMDER1 from the MINPACK package [1], which enables to exploit +C the structure of the problem, and optionally use condition +C estimation. Unstructured problems could be solved as well. +C +C Template SLICOT Library implementations for FCN, QRFACT and +C LMPARM routines are: +C MD03BF, MD03BA, and MD03BB, respectively, for standard problems; +C NF01BF, NF01BS, and NF01BP, respectively, for optimizing the +C parameters of Wiener systems (structured problems). +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Feb. 15, 2004. +C +C KEYWORDS +C +C Least-squares approximation, Levenberg-Marquardt algorithm, +C matrix operations, optimization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, FOUR, P1, P5, P25, P75, P0001 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, FOUR = 4.0D0, + $ P1 = 1.0D-1, P5 = 5.0D-1, P25 = 2.5D-1, + $ P75 = 7.5D-1, P0001 = 1.0D-4 ) +C .. Scalar Arguments .. + CHARACTER COND, SCALE, XINIT + INTEGER INFO, ITMAX, IWARN, LDPAR1, LDPAR2, LDWORK, + $ LIPAR, M, N, NFEV, NJEV, NPRINT + DOUBLE PRECISION FACTOR, FTOL, GTOL, TOL, XTOL +C .. Array Arguments .. + INTEGER IPAR(*), IWORK(*) + DOUBLE PRECISION DIAG(*), DPAR1(*), DPAR2(*), DWORK(*), X(*) +C .. Local Scalars .. + LOGICAL BADSCL, INIT, ISCAL, SSCAL + INTEGER E, IFLAG, INFOL, ITER, IW1, IW2, IW3, J, JAC, + $ JW1, JW2, JWORK, L, LDJ, LDJSAV, LFCN1, LFCN2, + $ LLMP, LQRF, NC, NFEVL, SIZEJ, WRKOPT + DOUBLE PRECISION ACTRED, DELTA, DIRDER, EPSMCH, FNORM, FNORM1, + $ FTDEF, GNORM, GTDEF, PAR, PNORM, PRERED, RATIO, + $ TEMP, TEMP1, TEMP2, TOLDEF, XNORM, XTDEF +C .. Local Arrays .. + INTEGER SEED(4) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARNV, FCN, LMPARM, QRFACT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD, SQRT +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INIT = LSAME( XINIT, 'R' ) + ISCAL = LSAME( SCALE, 'I' ) + SSCAL = LSAME( SCALE, 'S' ) + INFO = 0 + IWARN = 0 + IF( .NOT.( INIT .OR. LSAME( XINIT, 'G' ) ) ) THEN + INFO = -1 + ELSEIF( .NOT.( ISCAL .OR. SSCAL ) ) THEN + INFO = -2 + ELSEIF( .NOT.( LSAME( COND, 'E' ) .OR. LSAME( COND, 'N' ) ) ) THEN + INFO = -3 + ELSEIF( M.LT.0 ) THEN + INFO = -7 + ELSEIF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -8 + ELSEIF( ITMAX.LT.0 ) THEN + INFO = -9 + ELSEIF( FACTOR.LE.ZERO ) THEN + INFO = -10 + ELSEIF( LIPAR.LT.5 ) THEN + INFO = -13 + ELSEIF( LDPAR1.LT.0 ) THEN + INFO = -15 + ELSEIF( LDPAR2.LT.0 ) THEN + INFO = -17 + ELSEIF ( LDWORK.LT.4 ) THEN + INFO = -28 + ELSEIF ( SSCAL ) THEN + BADSCL = .FALSE. +C + DO 10 J = 1, N + BADSCL = BADSCL .OR. DIAG(J).LE.ZERO + 10 CONTINUE +C + IF ( BADSCL ) + $ INFO = -19 + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MD03BD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + NFEV = 0 + NJEV = 0 + IF ( N.EQ.0 ) THEN + DWORK(1) = FOUR + DWORK(2) = ZERO + DWORK(3) = ZERO + DWORK(4) = ZERO + RETURN + END IF +C +C Call FCN to get the size of the array J, for storing the Jacobian +C matrix, the leading dimension LDJ and the workspace required +C by FCN for IFLAG = 1 and IFLAG = 2, QRFACT and LMPARM. The +C entries DWORK(1:4) should not be modified by the special call of +C FCN below, if XINIT = 'R' and the values in DWORK(1:4) are +C explicitly desired for initialization of the random number +C generator. +C + IFLAG = 3 + IW1 = IPAR(1) + IW2 = IPAR(2) + IW3 = IPAR(3) + JW1 = IPAR(4) + JW2 = IPAR(5) +C + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, + $ X, NFEVL, DWORK, DWORK, LDJSAV, DWORK, LDWORK, INFOL ) + SIZEJ = IPAR(1) + LFCN1 = IPAR(2) + LFCN2 = IPAR(3) + LQRF = IPAR(4) + LLMP = IPAR(5) + IF ( LDJSAV.GT.0 ) THEN + NC = SIZEJ/LDJSAV + ELSE + NC = SIZEJ + END IF +C + IPAR(1) = IW1 + IPAR(2) = IW2 + IPAR(3) = IW3 + IPAR(4) = JW1 + IPAR(5) = JW2 +C +C Check the workspace length. +C + E = 1 + JAC = E + M + JW1 = JAC + SIZEJ + JW2 = JW1 + N + IW1 = JAC + N*NC + IW2 = IW1 + N + IW3 = IW2 + N + JWORK = IW2 + M +C + L = MAX( 4, M + MAX( SIZEJ + MAX( LFCN1, LFCN2, N + LQRF ), + $ N*NC + N + MAX( M + LFCN1, N + LLMP ) ) ) + IF ( LDWORK.LT.L ) THEN + INFO = -28 + CALL XERBLA( 'MD03BD', -INFO ) + RETURN + ENDIF +C +C Set default tolerances. EPSMCH is the machine precision. +C + EPSMCH = DLAMCH( 'Epsilon' ) + FTDEF = FTOL + XTDEF = XTOL + GTDEF = GTOL + TOLDEF = TOL + IF ( MIN( FTDEF, XTDEF, GTDEF, TOLDEF ).LE.ZERO ) THEN + IF ( FTDEF.LT.ZERO ) + $ FTDEF = SQRT( EPSMCH ) + IF ( XTDEF.LT.ZERO ) + $ XTDEF = SQRT( EPSMCH ) + IF ( GTDEF.LT.ZERO ) + $ GTDEF = EPSMCH + IF ( TOLDEF.LE.ZERO ) + $ TOLDEF = DBLE( N )*EPSMCH + ENDIF + WRKOPT = 1 +C +C Initialization. +C + IF ( INIT ) THEN +C +C SEED is the initial state of the random number generator. +C SEED(4) must be odd. +C + SEED(1) = MOD( INT( DWORK(1) ), 4096 ) + SEED(2) = MOD( INT( DWORK(2) ), 4096 ) + SEED(3) = MOD( INT( DWORK(3) ), 4096 ) + SEED(4) = MOD( 2*INT( DWORK(4) ) + 1, 4096 ) + CALL DLARNV( 2, SEED, N, X ) + ENDIF +C +C Initialize Levenberg-Marquardt parameter and iteration counter. +C + PAR = ZERO + ITER = 1 +C +C Evaluate the function at the starting point +C and calculate its norm. +C Workspace: need: M + SIZEJ + LFCN1; +C prefer: larger. +C + IFLAG = 1 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, LDPAR2, + $ X, NFEVL, DWORK(E), DWORK(JAC), LDJ, DWORK(JW1), + $ LDWORK-JW1+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) + NFEV = 1 + FNORM = DNRM2( M, DWORK(E), 1 ) + IF ( IFLAG.LT.0 .OR. FNORM.EQ.ZERO ) + $ GO TO 90 +C +C Beginning of the outer loop. +C + 20 CONTINUE +C +C Calculate the Jacobian matrix. +C Workspace: need: M + SIZEJ + LFCN2; +C prefer: larger. +C + LDJ = LDJSAV + IFLAG = 2 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEVL, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( INFOL.NE.0 ) THEN + INFO = 2 + RETURN + END IF + IF ( ITER.EQ.1 ) + $ WRKOPT = MAX( WRKOPT, INT( DWORK(JW1) ) + JW1 - 1 ) + IF ( NFEVL.GT.0 ) + $ NFEV = NFEV + NFEVL + NJEV = NJEV + 1 + IF ( IFLAG.LT.0 ) + $ GO TO 90 +C +C If requested, call FCN to enable printing of iterates. +C + IF ( NPRINT.GT.0 ) THEN + IFLAG = 0 + IF ( MOD( ITER-1, NPRINT ).EQ.0 ) THEN + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JW1), LDWORK-JW1+1, INFOL ) +C + IF ( IFLAG.LT.0 ) + $ GO TO 90 + END IF + END IF +C +C Compute the QR factorization of the Jacobian. +C Workspace: need: M + SIZEJ + N + LQRF; +C prefer: larger. +C + CALL QRFACT( N, IPAR, LIPAR, FNORM, DWORK(JAC), LDJ, DWORK(E), + $ DWORK(JW1), GNORM, IWORK, DWORK(JW2), + $ LDWORK-JW2+1, INFOL ) + IF ( INFOL.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C +C On the first iteration and if SCALE = 'I', scale according +C to the norms of the columns of the initial Jacobian. +C + IF ( ITER.EQ.1 ) THEN + WRKOPT = MAX( WRKOPT, INT( DWORK(JW2) ) + JW2 - 1 ) + IF ( ISCAL ) THEN +C + DO 30 J = 1, N + DIAG(J) = DWORK(JW1+J-1) + IF ( DIAG(J).EQ.ZERO ) + $ DIAG(J) = ONE + 30 CONTINUE +C + END IF +C +C On the first iteration, calculate the norm of the scaled +C x and initialize the step bound DELTA. +C + DO 40 J = 1, N + DWORK(IW1+J-1) = DIAG(J)*X(J) + 40 CONTINUE +C + XNORM = DNRM2( N, DWORK(IW1), 1 ) + DELTA = FACTOR*XNORM + IF ( DELTA.EQ.ZERO ) + $ DELTA = FACTOR + ELSE +C +C Rescale if necessary. +C + IF ( ISCAL ) THEN +C + DO 50 J = 1, N + DIAG(J) = MAX( DIAG(J), DWORK(JW1+J-1) ) + 50 CONTINUE +C + END IF + END IF +C +C Test for convergence of the gradient norm. +C + IF ( GNORM.LE.GTDEF ) + $ IWARN = 4 + IF ( IWARN.NE.0 ) + $ GO TO 90 +C +C Beginning of the inner loop. +C + 60 CONTINUE +C +C Determine the Levenberg-Marquardt parameter and the +C direction p, and compute -R*P'*p. +C Workspace: need: M + N*NC + 2*N + LLMP; +C prefer: larger. +C + CALL LMPARM( COND, N, IPAR, LIPAR, DWORK(JAC), LDJ, + $ IWORK, DIAG, DWORK(E), DELTA, PAR, IWORK(N+1), + $ DWORK(IW1), DWORK(IW2), TOLDEF, DWORK(IW3), + $ LDWORK-IW3+1, INFOL ) + IF ( INFOL.NE.0 ) THEN + INFO = 4 + RETURN + END IF + IF ( ITER.EQ.1 ) + $ WRKOPT = MAX( WRKOPT, INT( DWORK(IW3) ) + IW3 - 1 ) +C + TEMP1 = DNRM2( N, DWORK(IW2), 1 )/FNORM +C +C Store the direction p and x - p. +C + DO 70 J = 0, N - 1 + DWORK(IW2+J) = DIAG(J+1)*DWORK(IW1+J) + DWORK(IW1+J) = X(J+1) - DWORK(IW1+J) + 70 CONTINUE +C +C Compute the norm of scaled p and the scaled predicted +C reduction and the scaled directional derivative. +C + PNORM = DNRM2( N, DWORK(IW2), 1 ) + TEMP2 = ( SQRT( PAR )*PNORM )/FNORM + PRERED = TEMP1**2 + TEMP2**2/P5 + DIRDER = -( TEMP1**2 + TEMP2**2 ) +C +C On the first iteration, adjust the initial step bound. +C + IF ( ITER.EQ.1 ) + $ DELTA = MIN( DELTA, PNORM ) +C +C Evaluate the function at x - p and calculate its norm. +C Workspace: need: 2*M + N*NC + N + LFCN1; +C prefer: larger. +C + IFLAG = 1 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, DWORK(IW1), NFEVL, DWORK(IW2), DWORK(JAC), + $ LDJ, DWORK(JWORK), LDWORK-JWORK+1, INFOL ) + IF ( INFOL.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + NFEV = NFEV + 1 + IF ( IFLAG.LT.0 ) + $ GO TO 90 + FNORM1 = DNRM2( M, DWORK(IW2), 1 ) +C +C Compute the scaled actual reduction. +C + ACTRED = -ONE + IF ( P1*FNORM1.LT.FNORM ) + $ ACTRED = ONE - ( FNORM1/FNORM )**2 +C +C Compute the ratio of the actual to the predicted reduction. +C + RATIO = ZERO + IF ( PRERED.NE.ZERO ) + $ RATIO = ACTRED/PRERED +C +C Update the step bound. +C + IF ( RATIO.LE.P25 ) THEN + IF ( ACTRED.GE.ZERO ) THEN + TEMP = P5 + ELSE + TEMP = P5*DIRDER/( DIRDER + P5*ACTRED ) + END IF + IF ( P1*FNORM1.GE.FNORM .OR. TEMP.LT.P1 ) + $ TEMP = P1 + DELTA = TEMP*MIN( DELTA, PNORM/P1 ) + PAR = PAR/TEMP + ELSE + IF ( PAR.EQ.ZERO .OR. RATIO.GE.P75 ) THEN + DELTA = PNORM/P5 + PAR = P5*PAR + END IF + END IF +C +C Test for successful iteration. +C + IF ( RATIO.GE.P0001 ) THEN +C +C Successful iteration. Update x, e, and their norms. +C + DO 80 J = 1, N + X(J) = DWORK(IW1+J-1) + DWORK(IW1+J-1) = DIAG(J)*X(J) + 80 CONTINUE +C + CALL DCOPY( M, DWORK(IW2), 1, DWORK(E), 1 ) + XNORM = DNRM2( N, DWORK(IW1), 1 ) + FNORM = FNORM1 + ITER = ITER + 1 + END IF +C +C Tests for convergence. +C + IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. + $ P5*RATIO.LE.ONE ) + $ IWARN = 1 + IF ( DELTA.LE.XTDEF*XNORM ) + $ IWARN = 2 + IF ( ABS( ACTRED ).LE.FTDEF .AND. PRERED.LE.FTDEF .AND. + $ P5*RATIO.LE.ONE .AND. IWARN.EQ.2 ) + $ IWARN = 3 + IF ( IWARN.NE.0 ) + $ GO TO 90 +C +C Tests for termination and stringent tolerances. +C + IF ( ITER.GE.ITMAX ) + $ IWARN = 5 + IF ( ABS( ACTRED ).LE.EPSMCH .AND. PRERED.LE.EPSMCH .AND. + $ P5*RATIO.LE.ONE ) + $ IWARN = 6 + IF ( DELTA.LE.EPSMCH*XNORM ) + $ IWARN = 7 + IF ( GNORM.LE.EPSMCH ) + $ IWARN = 8 + IF ( IWARN.NE.0 ) + $ GO TO 90 +C +C End of the inner loop. Repeat if unsuccessful iteration. +C + IF ( RATIO.LT.P0001 ) GO TO 60 +C +C End of the outer loop. +C + GO TO 20 +C + 90 CONTINUE +C +C Termination, either normal or user imposed. +C Note that DWORK(JAC) normally contains the results returned by +C QRFACT and LMPARM (the compressed R and S factors). +C + IF ( IFLAG.LT.0 ) + $ IWARN = IFLAG + IF ( NPRINT.GT.0 ) THEN + IFLAG = 0 + CALL FCN( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEV, DWORK(E), DWORK(JAC), LDJ, + $ DWORK(JWORK), LDWORK-JWORK+1, INFOL ) + IF ( IFLAG.LT.0 ) + $ IWARN = IFLAG + END IF +C + IF ( IWARN.GE.0 ) THEN + DO 100 J = M + N*NC, 1, -1 + DWORK(4+J) = DWORK(J) + 100 CONTINUE + END IF + DWORK(1) = WRKOPT + DWORK(2) = FNORM + DWORK(3) = ITER + DWORK(4) = PAR +C + RETURN +C *** Last line of MD03BD *** + END diff --git a/mex/sources/libslicot/MD03BF.f b/mex/sources/libslicot/MD03BF.f new file mode 100644 index 000000000..232ac807d --- /dev/null +++ b/mex/sources/libslicot/MD03BF.f @@ -0,0 +1,122 @@ + SUBROUTINE MD03BF( IFLAG, M, N, IPAR, LIPAR, DPAR1, LDPAR1, DPAR2, + $ LDPAR2, X, NFEVL, E, J, LDJ, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for solving a standard nonlinear least +C squares problem using SLICOT Library routine MD03BD. See the +C parameter FCN in the routine MD03BD for the description of +C parameters. +C +C The example programmed in this routine is adapted from that +C accompanying the MINPACK routine LMDER. +C +C ****************************************************************** +C +C .. Parameters .. +C .. NOUT is the unit number for printing intermediate results .. + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDPAR1, LDPAR2, LDWORK, LIPAR, + $ M, N, NFEVL +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DPAR1(*), DPAR2(*), DWORK(*), E(*), J(LDJ,*), + $ X(*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ERR, TMP1, TMP2, TMP3, TMP4 +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. DATA Statements .. + DOUBLE PRECISION Y(15) + DATA Y(1), Y(2), Y(3), Y(4), Y(5), Y(6), Y(7), Y(8), + $ Y(9), Y(10), Y(11), Y(12), Y(13), Y(14), Y(15) + $ / 1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, + $ 3.2D-1, 3.5D-1, 3.9D-1, 3.7D-1, 5.8D-1, + $ 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0 / +C +C .. Executable Statements .. +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Compute the error function values. +C + DO 10 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + IF ( I.GT.8 ) THEN + TMP3 = TMP2 + ELSE + TMP3 = TMP1 + END IF + E(I) = Y(I) - ( X(1) + TMP1/( X(2)*TMP2 + X(3)*TMP3 ) ) + 10 CONTINUE +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Compute the Jacobian. +C + DO 30 I = 1, 15 + TMP1 = I + TMP2 = 16 - I + IF ( I.GT.8 ) THEN + TMP3 = TMP2 + ELSE + TMP3 = TMP1 + END IF + TMP4 = ( X(2)*TMP2 + X(3)*TMP3 )**2 + J(I,1) = -ONE + J(I,2) = TMP1*TMP2/TMP4 + J(I,3) = TMP1*TMP3/TMP4 + 30 CONTINUE +C + NFEVL = 0 +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), MD03BA and MD03BB. +C + LDJ = M + IPAR(1) = M*N + IPAR(2) = 0 + IPAR(3) = 0 + IPAR(4) = 4*N + 1 + IPAR(5) = 4*N +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( M, E, 1 ) + WRITE( 1, '('' Norm of current error = '', D15.6)') ERR +C + END IF +C + RETURN +C +C *** Last line of MD03BF *** + END diff --git a/mex/sources/libslicot/MD03BX.f b/mex/sources/libslicot/MD03BX.f new file mode 100644 index 000000000..7ffef61d0 --- /dev/null +++ b/mex/sources/libslicot/MD03BX.f @@ -0,0 +1,255 @@ + SUBROUTINE MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the QR factorization with column pivoting of an +C m-by-n matrix J (m >= n), that is, J*P = Q*R, where Q is a matrix +C with orthogonal columns, P a permutation matrix, and R an upper +C trapezoidal matrix with diagonal elements of nonincreasing +C magnitude, and to apply the transformation Q' on the error +C vector e (in-situ). The 1-norm of the scaled gradient is also +C returned. The matrix J could be the Jacobian of a nonlinear least +C squares problem. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the Jacobian matrix J. M >= 0. +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. +C M >= N >= 0. +C +C FNORM (input) DOUBLE PRECISION +C The Euclidean norm of the vector e. FNORM >= 0. +C +C J (input/output) DOUBLE PRECISION array, dimension (LDJ, N) +C On entry, the leading M-by-N part of this array must +C contain the Jacobian matrix J. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular factor R of the +C Jacobian matrix. Note that for efficiency of the later +C calculations, the matrix R is delivered with the leading +C dimension MAX(1,N), possibly much smaller than the value +C of LDJ on entry. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. +C On entry, LDJ >= MAX(1,M). +C On exit, LDJ >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the error vector e. +C On exit, this array contains the updated vector Q'*e. +C +C JNORMS (output) DOUBLE PRECISION array, dimension (N) +C This array contains the Euclidean norms of the columns of +C the Jacobian matrix, considered in the initial order. +C +C GNORM (output) DOUBLE PRECISION +C If FNORM > 0, the 1-norm of the scaled vector +C J'*Q'*e/FNORM, with each element i further divided by +C JNORMS(i) (if JNORMS(i) is nonzero). +C If FNORM = 0, the returned value of GNORM is 0. +C +C IPVT (output) INTEGER array, dimension (N) +C This array defines the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1, if N = 0 or M = 1; +C LDWORK >= 4*N+1, if N > 1. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The algorithm uses QR factorization with column pivoting of the +C matrix J, J*P = Q*R, and applies the orthogonal matrix Q' to the +C vector e. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Elementary matrix operations, Jacobian matrix, matrix algebra, +C matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDJ, LDWORK, M, N + DOUBLE PRECISION FNORM, GNORM +C .. Array Arguments .. + INTEGER IPVT(*) + DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) +C .. Local Scalars .. + INTEGER I, ITAU, JWORK, L, WRKOPT + DOUBLE PRECISION SUM +C .. External Functions .. + DOUBLE PRECISION DDOT, DNRM2 + EXTERNAL DDOT, DNRM2 +C .. External Subroutines .. + EXTERNAL DGEQP3, DLACPY, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX +C .. +C .. Executable Statements .. +C + INFO = 0 + IF ( M.LT.0 ) THEN + INFO = -1 + ELSEIF ( N.LT.0.OR. M.LT.N ) THEN + INFO = -2 + ELSEIF ( FNORM.LT.ZERO ) THEN + INFO = -3 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE + IF ( N.EQ.0 .OR. M.EQ.1 ) THEN + JWORK = 1 + ELSE + JWORK = 4*N + 1 + END IF + IF ( LDWORK.LT.JWORK ) + $ INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'MD03BX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + GNORM = ZERO + IF ( N.EQ.0 ) THEN + LDJ = 1 + DWORK(1) = ONE + RETURN + ELSEIF ( M.EQ.1 ) THEN + JNORMS(1) = ABS( J(1) ) + IF ( FNORM*J(1).NE.ZERO ) + $ GNORM = ABS( E(1)/FNORM ) + LDJ = 1 + IPVT(1) = 1 + DWORK(1) = ONE + RETURN + END IF +C +C Initialize the column pivoting indices. +C + DO 10 I = 1, N + IPVT(I) = 0 + 10 CONTINUE +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + ITAU = 1 + JWORK = ITAU + N + WRKOPT = 1 +C +C Compute the QR factorization with pivoting of J, and apply Q' to +C the vector e. +C +C Workspace: need: 4*N + 1; +C prefer: 3*N + ( N+1 )*NB. +C + CALL DGEQP3( M, N, J, LDJ, IPVT, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Workspace: need: N + 1; +C prefer: N + NB. +C + CALL DORMQR( 'Left', 'Transpose', M, 1, N, J, LDJ, DWORK(ITAU), E, + $ M, DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C + IF ( LDJ.GT.N ) THEN +C +C Reshape the array J to have the leading dimension N. +C This destroys the details of the orthogonal matrix Q. +C + CALL DLACPY( 'Upper', N, N, J, LDJ, J, N ) + LDJ = N + END IF +C +C Compute the norm of the scaled gradient and original column norms. +C + IF ( FNORM.NE.ZERO ) THEN +C + DO 20 I = 1, N + L = IPVT(I) + JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) + IF ( JNORMS(L).NE.ZERO ) THEN + SUM = DDOT( I, J((I-1)*LDJ+1), 1, E, 1 )/FNORM + GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) + END IF + 20 CONTINUE +C + ELSE +C + DO 30 I = 1, N + L = IPVT(I) + JNORMS(L) = DNRM2( I, J((I-1)*LDJ+1), 1 ) + 30 CONTINUE +C + END IF +C + DWORK(1) = WRKOPT + RETURN +C +C *** Last line of MD03BX *** + END diff --git a/mex/sources/libslicot/MD03BY.f b/mex/sources/libslicot/MD03BY.f new file mode 100644 index 000000000..ec4637ce4 --- /dev/null +++ b/mex/sources/libslicot/MD03BY.f @@ -0,0 +1,514 @@ + SUBROUTINE MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, + $ RANK, X, RX, TOL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a value for the parameter PAR such that if x solves +C the system +C +C A*x = b , sqrt(PAR)*D*x = 0 , +C +C in the least squares sense, where A is an m-by-n matrix, D is an +C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if +C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, +C then either PAR is zero and +C +C ( DXNORM - DELTA ) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . +C +C It is assumed that a QR factorization, with column pivoting, of A +C is available, that is, A*P = Q*R, where P is a permutation matrix, +C Q has orthogonal columns, and R is an upper triangular matrix +C with diagonal elements of nonincreasing magnitude. +C The routine needs the full upper triangle of R, the permutation +C matrix P, and the first n components of Q'*b (' denotes the +C transpose). On output, MD03BY also provides an upper triangular +C matrix S such that +C +C P'*(A'*A + PAR*D*D)*P = S'*S . +C +C Matrix S is used in the solution process. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the matrices R and S +C should be estimated, as follows: +C = 'E' : use incremental condition estimation for R and S; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of R and S for zero values; +C = 'U' : use the rank already stored in RANK (for R). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N >= 0. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the full upper triangle is unaltered, and the +C strict lower triangle contains the strict upper triangle +C (transposed) of the upper triangular matrix S. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C A*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. DIAG(I) <> 0, I = 1,...,N. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C DELTA (input) DOUBLE PRECISION +C An upper bound on the Euclidean norm of D*x. DELTA > 0. +C +C PAR (input/output) DOUBLE PRECISION +C On entry, PAR must contain an initial estimate of the +C Levenberg-Marquardt parameter. PAR >= 0. +C On exit, it contains the final estimate of this parameter. +C +C RANK (input or output) INTEGER +C On entry, if COND = 'U', this parameter must contain the +C (numerical) rank of the matrix R. +C On exit, this parameter contains the numerical rank of +C the matrix S. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system A*x = b, sqrt(PAR)*D*x = 0. +C +C RX (output) DOUBLE PRECISION array, dimension (N) +C This array contains the matrix-vector product -R*P'*x. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C rank of the matrices R and S. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C the reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 4*N, if COND = 'E'; +C LDWORK >= 2*N, if COND <> 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The algorithm computes the Gauss-Newton direction. A least squares +C solution is found if the Jacobian is rank deficient. If the Gauss- +C Newton direction is not acceptable, then an iterative algorithm +C obtains improved lower and upper bounds for the parameter PAR. +C Only a few iterations are generally needed for convergence of the +C algorithm. If, however, the limit of ITMAX = 10 iterations is +C reached, then the output PAR will contain the best value obtained +C so far. If the Gauss-Newton step is acceptable, it is stored in x, +C and PAR is set to zero, hence S = R. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C This routine is a LAPACK-based modification of LMPAR from the +C MINPACK package [1], and with optional condition estimation. +C The option COND = 'U' is useful when dealing with several +C right-hand side vectors, but RANK should be reset. +C If COND = 'E', but the matrix S is guaranteed to be nonsingular +C and well conditioned relative to TOL, i.e., rank(R) = N, and +C min(DIAG) > 0, then its condition is not estimated. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 10 ) + DOUBLE PRECISION P1, P001, ZERO, SVLMAX + PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, + $ SVLMAX = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, N, RANK + DOUBLE PRECISION DELTA, PAR, TOL +C .. Array Arguments .. + INTEGER IPVT(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) +C .. Local Scalars .. + INTEGER ITER, J, L, N2 + DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, + $ PARU, TEMP, TOLDEF + LOGICAL ECOND, NCOND, SING, UCOND + CHARACTER CONDL +C .. Local Arrays .. + DOUBLE PRECISION DUM(3) +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSWAP, DTRMV, DTRSV, MB02YD, + $ MB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + NCOND = LSAME( COND, 'N' ) + UCOND = LSAME( COND, 'U' ) + INFO = 0 + IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN + INFO = -1 + ELSEIF( N.LT.0 ) THEN + INFO = -2 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( DELTA.LE.ZERO ) THEN + INFO = -8 + ELSEIF( PAR.LT.ZERO ) THEN + INFO = -9 + ELSEIF ( UCOND .AND. ( RANK.LT.0 .OR. RANK.GT.N ) ) THEN + INFO = -10 + ELSEIF ( LDWORK.LT.2*N .OR. ( ECOND .AND. LDWORK.LT.4*N ) ) THEN + INFO = -15 + ELSEIF ( N.GT.0 ) THEN + DMINO = DIAG(1) + SING = .FALSE. +C + DO 10 J = 1, N + IF ( DIAG(J).LT.DMINO ) + $ DMINO = DIAG(J) + SING = SING .OR. DIAG(J).EQ.ZERO + 10 CONTINUE +C + IF ( SING ) + $ INFO = -6 + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'MD03BY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + PAR = ZERO + RANK = 0 + RETURN + END IF +C +C DWARF is the smallest positive magnitude. +C + DWARF = DLAMCH( 'Underflow' ) + N2 = N +C +C Estimate the rank of R, if required. +C + IF ( ECOND ) THEN + N2 = 2*N + TEMP = TOL + IF ( TEMP.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + TEMP = DBLE( N )*DLAMCH( 'Epsilon' ) + END IF +C +C Estimate the reciprocal condition number of R and set the rank. +C Workspace: 2*N. +C + CALL MB03OD( 'No QR', N, N, R, LDR, IPVT, TEMP, SVLMAX, DWORK, + $ RANK, DUM, DWORK, LDWORK, INFO ) +C + ELSEIF ( NCOND ) THEN + J = 1 +C + 20 CONTINUE + IF ( R(J,J).NE.ZERO ) THEN + J = J + 1 + IF ( J.LE.N ) + $ GO TO 20 + END IF +C + RANK = J - 1 + END IF +C +C Compute and store in x the Gauss-Newton direction. If the +C Jacobian is rank-deficient, obtain a least squares solution. +C The array RX is used as workspace. +C + CALL DCOPY( RANK, QTB, 1, RX, 1 ) + DUM(1) = ZERO + IF ( RANK.LT.N ) + $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) + CALL DTRSV( 'Upper', 'No transpose', 'Non unit', RANK, R, LDR, + $ RX, 1 ) +C + DO 30 J = 1, N + L = IPVT(J) + X(L) = RX(J) + 30 CONTINUE +C +C Initialize the iteration counter. +C Evaluate the function at the origin, and test +C for acceptance of the Gauss-Newton direction. +C + ITER = 0 +C + DO 40 J = 1, N + DWORK(J) = DIAG(J)*X(J) + 40 CONTINUE +C + DXNORM = DNRM2( N, DWORK, 1 ) + FP = DXNORM - DELTA + IF ( FP.GT.P1*DELTA ) THEN +C +C Set an appropriate option for estimating the condition of +C the matrix S. +C + IF ( UCOND ) THEN + IF ( LDWORK.GE.4*N ) THEN + CONDL = 'E' + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + ELSE + CONDL = 'N' + TOLDEF = TOL + END IF + ELSE + CONDL = COND + TOLDEF = TOL + END IF +C +C If the Jacobian is not rank deficient, the Newton +C step provides a lower bound, PARL, for the zero of +C the function. Otherwise set this bound to zero. +C + IF ( RANK.EQ.N ) THEN +C + DO 50 J = 1, N + L = IPVT(J) + RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) + 50 CONTINUE +C + CALL DTRSV( 'Upper', 'Transpose', 'Non unit', N, R, LDR, + $ RX, 1 ) + TEMP = DNRM2( N, RX, 1 ) + PARL = ( ( FP/DELTA )/TEMP )/TEMP +C +C For efficiency, use CONDL = 'U', if possible. +C + IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) + $ CONDL = 'U' + ELSE + PARL = ZERO + END IF +C +C Calculate an upper bound, PARU, for the zero of the function. +C + DO 60 J = 1, N + L = IPVT(J) + RX(J) = DDOT( J, R(1,J), 1, QTB, 1 )/DIAG(L) + 60 CONTINUE +C + GNORM = DNRM2( N, RX, 1 ) + PARU = GNORM/DELTA + IF ( PARU.EQ.ZERO ) + $ PARU = DWARF/MIN( DELTA, P1 )/P001 +C +C If the input PAR lies outside of the interval (PARL,PARU), +C set PAR to the closer endpoint. +C + PAR = MAX( PAR, PARL ) + PAR = MIN( PAR, PARU ) + IF ( PAR.EQ.ZERO ) + $ PAR = GNORM/DXNORM +C +C Beginning of an iteration. +C + 70 CONTINUE + ITER = ITER + 1 +C +C Evaluate the function at the current value of PAR. +C + IF ( PAR.EQ.ZERO ) + $ PAR = MAX( DWARF, P001*PARU ) + TEMP = SQRT( PAR ) +C + DO 80 J = 1, N + RX(J) = TEMP*DIAG(J) + 80 CONTINUE +C +C Solve the system A*x = b , sqrt(PAR)*D*x = 0 , in a least +C square sense. The first N elements of DWORK contain the +C diagonal elements of the upper triangular matrix S, and +C the next N elements contain the vector z, so that x = P*z. +C The vector z is preserved if COND = 'E'. +C Workspace: 4*N, if CONDL = 'E'; +C 2*N, if CONDL <> 'E'. +C + CALL MB02YD( CONDL, N, R, LDR, IPVT, RX, QTB, RANK, X, + $ TOLDEF, DWORK, LDWORK, INFO ) +C + DO 90 J = 1, N + DWORK(N2+J) = DIAG(J)*X(J) + 90 CONTINUE +C + DXNORM = DNRM2( N, DWORK(N2+1), 1 ) + TEMP = FP + FP = DXNORM - DELTA +C +C If the function is small enough, accept the current value +C of PAR. Also test for the exceptional cases where PARL +C is zero or the number of iterations has reached ITMAX. +C + IF ( ABS( FP ).GT.P1*DELTA .AND. + $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. + $ ITER.LT.ITMAX ) THEN +C +C Compute the Newton correction. +C + DO 100 J = 1, RANK + L = IPVT(J) + RX(J) = DIAG(L)*( DWORK(N2+L)/DXNORM ) + 100 CONTINUE +C + IF ( RANK.LT.N ) + $ CALL DCOPY( N-RANK, DUM, 0, RX(RANK+1), 1 ) + CALL DSWAP( N, R, LDR+1, DWORK, 1 ) + CALL DTRSV( 'Lower', 'No transpose', 'Non Unit', RANK, + $ R, LDR, RX, 1 ) + CALL DSWAP( N, R, LDR+1, DWORK, 1 ) + TEMP = DNRM2( RANK, RX, 1 ) + PARC = ( ( FP/DELTA )/TEMP )/TEMP +C +C Depending on the sign of the function, update PARL +C or PARU. +C + IF ( FP.GT.ZERO ) THEN + PARL = MAX( PARL, PAR ) + ELSE IF ( FP.LT.ZERO ) THEN + PARU = MIN( PARU, PAR ) + END IF +C +C Compute an improved estimate for PAR. +C + PAR = MAX( PARL, PAR + PARC ) +C +C End of an iteration. +C + GO TO 70 + END IF + END IF +C +C Compute -R*P'*x = -R*z. +C + IF ( ECOND .AND. ITER.GT.0 ) THEN +C + DO 110 J = 1, N + RX(J) = -DWORK(N+J) + 110 CONTINUE +C + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, R, LDR, + $ RX, 1 ) + ELSE +C + DO 120 J = 1, N + RX(J) = ZERO + L = IPVT(J) + CALL DAXPY( J, -X(L), R(1,J), 1, RX, 1 ) + 120 CONTINUE +C + END IF +C +C Termination. If PAR = 0, set S. +C + IF ( ITER.EQ.0 ) THEN + PAR = ZERO +C + DO 130 J = 1, N - 1 + DWORK(J) = R(J,J) + CALL DCOPY( N-J, R(J,J+1), LDR, R(J+1,J), 1 ) + 130 CONTINUE +C + DWORK(N) = R(N,N) + END IF +C + RETURN +C +C *** Last line of MD03BY *** + END diff --git a/mex/sources/libslicot/NF01AD.f b/mex/sources/libslicot/NF01AD.f new file mode 100644 index 000000000..16af66a25 --- /dev/null +++ b/mex/sources/libslicot/NF01AD.f @@ -0,0 +1,230 @@ + SUBROUTINE NF01AD( NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, Y, LDY, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate the output y of the Wiener system +C +C x(t+1) = A*x(t) + B*u(t) +C z(t) = C*x(t) + D*u(t), +C +C y(t) = f(z(t),wb(1:L)), +C +C where t = 1, 2, ..., NSMP, and f is a nonlinear function, +C evaluated by the SLICOT Library routine NF01AY. The parameter +C vector X is partitioned as X = ( wb(1), ..., wb(L), theta ), +C where wb(i), i = 1:L, correspond to the nonlinear part, theta +C corresponds to the linear part, and the notation is fully +C described below. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NSMP (input) INTEGER +C The number of training samples. NSMP >= 0. +C +C M (input) INTEGER +C The length of each input sample. M >= 0. +C +C L (input) INTEGER +C The length of each output sample. L >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters needed. +C IPAR(1) must contain the order of the linear part, +C referred to as N below. N >= 0. +C IPAR(2) must contain the number of neurons for the +C nonlinear part, referred to as NN below. +C NN >= 0. +C +C LIPAR (input) INTEGER +C The length of IPAR. LIPAR >= 2. +C +C X (input) DOUBLE PRECISION array, dimension (LX) +C The parameter vector, partitioned as +C X = (wb(1), ..., wb(L), theta), where the vectors +C wb(i), of length NN*(L+2)+1, are parameters for the +C static nonlinearity, which is simulated by the +C SLICOT Library routine NF01AY. See the documentation of +C NF01AY for further details. The vector theta, of length +C N*(M + L + 1) + L*M, represents the matrices A, B, C, +C D and x(1), and it can be retrieved from these matrices +C by SLICOT Library routine TB01VD and retranslated by +C TB01VY. +C +C LX (input) INTEGER +C The length of the array X. +C LX >= ( NN*(L+2)+1 )*L + N*(M + L + 1) + L*M. +C +C U (input) DOUBLE PRECISION array, dimension (LDU, M) +C The leading NSMP-by-M part of this array must contain the +C set of input samples, +C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). +C +C LDU INTEGER +C The leading dimension of the array U. LDU >= MAX(1,NSMP). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY, L) +C The leading NSMP-by-L part of this array contains the +C simulated output. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ) +C if M > 0; +C LDWORK >= NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M = 0. +C A larger value of LDWORK could improve the efficiency. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C METHOD +C +C BLAS routines are used for the matrix-vector multiplications and +C the routine NF01AY is called for the calculation of the nonlinear +C function. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Mar. 2001, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Dec. 2001. +C +C KEYWORDS +C +C Nonlinear system, output normal form, simulation, state-space +C representation, Wiener system. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, L, LDU, LDWORK, LDY, LX, LIPAR, M, NSMP +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER AC, BD, IX, JW, LDAC, LTHS, N, NN, NTHS, Z +C .. External Subroutines .. + EXTERNAL NF01AY, TB01VY, TF01MX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + IF ( NSMP.LT.0 ) THEN + INFO = -1 + ELSEIF ( M.LT.0 ) THEN + INFO = -2 + ELSEIF ( L.LT.0 ) THEN + INFO = -3 + ELSEIF ( LIPAR.LT.2 ) THEN + INFO = -5 + ELSE +C + N = IPAR(1) + NN = IPAR(2) + LDAC = N + L + NTHS = ( NN*( L + 2 ) + 1 )*L + LTHS = N*( M + L + 1 ) + L*M +C + IF ( N.LT.0 .OR. NN.LT.0 ) THEN + INFO = -4 + ELSEIF ( LX.LT.NTHS + LTHS ) THEN + INFO = -7 + ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN + INFO = -9 + ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -11 + ELSE + IF ( M.GT.0 ) THEN + JW = MAX( N*LDAC, N + M + L ) + ELSE + JW = MAX( N*LDAC, L ) + END IF + IF ( LDWORK.LT.NSMP*L + MAX( 2*NN, LDAC*( N + M ) + 2*N + + $ JW ) ) + $ INFO = -13 + ENDIF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01AD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MIN( NSMP, L ).EQ.0 ) + $ RETURN +C +C Compute the output of the linear part. +C Workspace: need NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). +C (NSMP*L locations are reserved for the output of the linear part.) +C + Z = 1 + AC = Z + NSMP*L + BD = AC + LDAC*N + IX = BD + LDAC*M + JW = IX + N +C + CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, + $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), + $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) +C +C Workspace: need NSMP*L + (N + L)*(N + M) + 3*N + M + L, if M>0; +C NSMP*L + (N + L)*N + 2*N + L, if M=0; +C prefer larger. +C + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), + $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) +C +C Simulate the static nonlinearity. +C Workspace: need NSMP*L + 2*NN; +C prefer larger. +C + JW = AC + CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), + $ NSMP, Y, LDY, DWORK(JW), LDWORK-JW+1, INFO ) +C + RETURN +C +C *** Last line of NF01AD *** + END diff --git a/mex/sources/libslicot/NF01AY.f b/mex/sources/libslicot/NF01AY.f new file mode 100644 index 000000000..cc9782a86 --- /dev/null +++ b/mex/sources/libslicot/NF01AY.f @@ -0,0 +1,353 @@ + SUBROUTINE NF01AY( NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, LDZ, + $ Y, LDY, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate the output of a set of neural networks with the +C structure +C +C - tanh(w1'*z+b1) - +C / : \ +C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, +C \ : / +C - tanh(wn'*z+bn) - +C +C given the input z and the parameter vectors wi, ws, and b, +C where z, w1, ..., wn are vectors of length NZ, ws is a vector +C of length n, b(1), ..., b(n+1) are scalars, and n is called the +C number of neurons in the hidden layer, or just number of neurons. +C Such a network is used for each L output variables. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NSMP (input) INTEGER +C The number of training samples. NSMP >= 0. +C +C NZ (input) INTEGER +C The length of each input sample. NZ >= 0. +C +C L (input) INTEGER +C The length of each output sample. L >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters needed. +C IPAR(1) must contain the number of neurons, n, per output +C variable, denoted NN in the sequel. NN >= 0. +C +C LIPAR (input) INTEGER +C The length of the vector IPAR. LIPAR >= 1. +C +C WB (input) DOUBLE PRECISION array, dimension (LWB) +C The leading (NN*(NZ+2)+1)*L part of this array must +C contain the weights and biases of the network. This vector +C is partitioned into L vectors of length NN*(NZ+2)+1, +C WB = [ wb(1), ..., wb(L) ]. Each wb(k), k = 1, ..., L, +C corresponds to one output variable, and has the structure +C wb(k) = [ w1(1), ..., w1(NZ), ..., wn(1), ..., wn(NZ), +C ws(1), ..., ws(n), b(1), ..., b(n+1) ], +C where wi(j) are the weights of the hidden layer, +C ws(i) are the weights of the linear output layer, and +C b(i) are the biases, as in the scheme above. +C +C LWB (input) INTEGER +C The length of the array WB. +C LWB >= ( NN*(NZ + 2) + 1 )*L. +C +C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) +C The leading NSMP-by-NZ part of this array must contain the +C set of input samples, +C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= MAX(1,NSMP). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY, L) +C The leading NSMP-by-L part of this array contains the set +C of output samples, +C Y = ( Y(1,1),...,Y(1,L); ...; Y(NSMP,1),...,Y(NSMP,L) ). +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= MAX(1,NSMP). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 2*NN. +C For better performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C BLAS routines are used to compute the matrix-vector products. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Input output description, neural network, nonlinear system, +C simulation, system response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, L, LDWORK, LDY, LDZ, LIPAR, LWB, NSMP, NZ +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), WB(*), Y(LDY,*), Z(LDZ,*) + INTEGER IPAR(*) +C .. Local Scalars .. + LOGICAL LAST + INTEGER I, IB, J, K, LDWB, LJ, LK, M, MF, NN, NV, WS + DOUBLE PRECISION BIGNUM, DF, SMLNUM, TMP +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, EXP, LOG, MAX, MIN, MOD +C .. +C .. Executable Statements .. +C + INFO = 0 + NN = IPAR(1) + LDWB = NN*( NZ + 2 ) + 1 + IF ( NSMP.LT.0 ) THEN + INFO = -1 + ELSEIF ( NZ.LT.0 ) THEN + INFO = -2 + ELSEIF ( L.LT.0 ) THEN + INFO = -3 + ELSEIF ( NN.LT.0 ) THEN + INFO = -4 + ELSEIF ( LIPAR.LT.1 ) THEN + INFO = -5 + ELSEIF ( LWB.LT.LDWB*L ) THEN + INFO = -7 + ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN + INFO = -9 + ELSEIF ( LDY.LT.MAX( 1, NSMP ) ) THEN + INFO = -11 + ELSEIF ( LDWORK.LT.2*NN ) THEN + INFO = -13 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01AY', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MIN( NSMP, L ).EQ.0 ) + $ RETURN +C +C Set parameters to avoid overflows and increase accuracy for +C extreme values. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = LOG( SMLNUM ) + BIGNUM = LOG( BIGNUM ) +C + WS = NZ*NN + 1 + IB = WS + NN - 1 + LK = 0 + IF ( MIN( NZ, NN ).EQ.0 ) THEN + NV = 2 + ELSE + NV = ( LDWORK - NN )/NN + END IF +C + IF ( NV.GT.2 ) THEN + MF = ( NSMP/NV )*NV + LAST = MOD( NSMP, NV ).NE.0 +C +C Some BLAS 3 calculations can be used. +C + DO 70 K = 0, L - 1 + TMP = WB(IB+NN+1+LK) +C + DO 10 J = 1, NN + DWORK(J) = TWO*WB(IB+J+LK) + 10 CONTINUE +C + DO 40 I = 1, MF, NV +C +C Compute -2*[w1 w2 ... wn]'*Z', where +C Z = [z(i)';...; z(i+NV-1)']. +C + CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, + $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), + $ NN ) + LJ = NN +C + DO 30 M = 1, NV + DO 20 J = 1, NN +C +C Compute tanh(wj'*z(i) + bj), j = 1:n. +C + LJ = LJ + 1 + DF = DWORK(LJ) - DWORK(J) + IF ( ABS( DF ).GE.BIGNUM ) THEN + IF ( DF.GT.ZERO ) THEN + DWORK(LJ) = -ONE + ELSE + DWORK(LJ) = ONE + END IF + ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN + DWORK(LJ) = ZERO + ELSE + DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE + END IF + 20 CONTINUE +C + 30 CONTINUE +C + Y(I, K+1) = TMP + CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) + CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, + $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) + 40 CONTINUE +C + IF ( LAST ) THEN +C +C Process the last samples. +C + NV = NSMP - MF + I = MF + 1 +C +C Compute -2*[w1 w2 ... wn]'*Z', where +C Z = [z(i)';...; z(NSMP)']. +C + CALL DGEMM( 'Transpose', 'Transpose', NN, NV, NZ, -TWO, + $ WB(1+LK), NZ, Z(I,1), LDZ, ZERO, DWORK(NN+1), + $ NN ) + LJ = NN +C + DO 60 M = 1, NV + DO 50 J = 1, NN +C +C Compute tanh(wj'*z(i) + bj), j = 1:n. +C + LJ = LJ + 1 + DF = DWORK(LJ) - DWORK(J) + IF ( ABS( DF ).GE.BIGNUM ) THEN + IF ( DF.GT.ZERO ) THEN + DWORK(LJ) = -ONE + ELSE + DWORK(LJ) = ONE + END IF + ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN + DWORK(LJ) = ZERO + ELSE + DWORK(LJ) = TWO/( ONE + EXP( DF ) ) - ONE + END IF + 50 CONTINUE +C + 60 CONTINUE +C + Y(I, K+1) = TMP + IF ( NV.GT.1 ) + $ CALL DCOPY( NV-1, Y(I, K+1), 0, Y(I+1, K+1), 1 ) + CALL DGEMV( 'Transpose', NN, NV, ONE, DWORK(NN+1), NN, + $ WB(WS+LK), 1, ONE, Y(I, K+1), 1 ) + END IF +C + LK = LK + LDWB + 70 CONTINUE +C + ELSE +C +C BLAS 2 calculations only can be used. +C + DO 110 K = 0, L - 1 + TMP = WB(IB+NN+1+LK) +C + DO 80 J = 1, NN + DWORK(J) = TWO*WB(IB+J+LK) + 80 CONTINUE +C + DO 100 I = 1, NSMP +C +C Compute -2*[w1 w2 ... wn]'*z(i). +C + IF ( NZ.EQ.0 ) THEN + DWORK(NN+1) = ZERO + CALL DCOPY( NN, DWORK(NN+1), 0, DWORK(NN+1), 1 ) + ELSE + CALL DGEMV( 'Transpose', NZ, NN, -TWO, WB(1+LK), NZ, + $ Z(I,1), LDZ, ZERO, DWORK(NN+1), 1 ) + END IF +C + DO 90 J = NN + 1, 2*NN +C +C Compute tanh(wj'*z(i) + bj), j = 1:n. +C + DF = DWORK(J) - DWORK(J-NN) + IF ( ABS( DF ).GE.BIGNUM ) THEN + IF ( DF.GT.ZERO ) THEN + DWORK(J) = -ONE + ELSE + DWORK(J) = ONE + END IF + ELSE IF ( ABS( DF ).LE.SMLNUM ) THEN + DWORK(J) = ZERO + ELSE + DWORK(J) = TWO/( ONE + EXP( DF ) ) - ONE + END IF + 90 CONTINUE +C + Y(I, K+1) = DDOT( NN, WB(WS+LK), 1, DWORK(NN+1), 1 ) + + $ TMP + 100 CONTINUE +C + LK = LK + LDWB + 110 CONTINUE +C + END IF + RETURN +C +C *** Last line of NF01AY *** + END diff --git a/mex/sources/libslicot/NF01BA.f b/mex/sources/libslicot/NF01BA.f new file mode 100644 index 000000000..98c344a37 --- /dev/null +++ b/mex/sources/libslicot/NF01BA.f @@ -0,0 +1,104 @@ + SUBROUTINE NF01BA( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, + $ NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for optimizing the parameters of the +C nonlinear part of a Wiener system (initialization phase), using +C SLICOT Library routine MD03AD. See the argument FCN in the +C routine MD03AD for the description of parameters. Note that +C NF01BA is called for each output of the Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. +C .. CJTE is initialized to activate the calculation of J'*e .. +C .. NOUT is the unit number for printing intermediate results .. + CHARACTER CJTE + PARAMETER ( CJTE = 'C' ) + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, + $ NFEVL, NSMP +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), X(*), + $ Y(LDY,*), Z(LDZ,*) +C .. Local Scalars .. + DOUBLE PRECISION ERR +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. External Subroutines .. + EXTERNAL DAXPY, NF01AY, NF01BY +C +C .. Executable Statements .. +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Call NF01AY to compute the output y of the Wiener system (in E) +C and then the error functions (also in E). The array Z must +C contain the output of the linear part of the Wiener system, and +C Y must contain the original output Y of the Wiener system. +C IPAR(2) must contain the number of outputs. +C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); +C prefer: larger. +C + CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, + $ E, NSMP, DWORK, LDWORK, INFO ) + CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) + DWORK(1) = 2*IPAR(3) +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Call NF01BY to compute the Jacobian in a compressed form. +C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. +C Workspace: need: 0. +C + CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, + $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) + NFEVL = 0 + DWORK(1) = ZERO +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), and JPJ. +C + LDJ = NSMP + IPAR(1) = NSMP*N + IPAR(2) = 2*IPAR(3) + IPAR(3) = 0 + IPAR(4) = NSMP +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( NSMP, E, 1 ) + WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR + END IF + RETURN +C +C *** Last line of NF01BA *** + END diff --git a/mex/sources/libslicot/NF01BB.f b/mex/sources/libslicot/NF01BB.f new file mode 100644 index 000000000..ec39f9b38 --- /dev/null +++ b/mex/sources/libslicot/NF01BB.f @@ -0,0 +1,138 @@ + SUBROUTINE NF01BB( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, + $ X, NFEVL, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for optimizing all parameters of a Wiener +C system using SLICOT Library routine MD03AD. See the argument FCN +C in the routine MD03AD for the description of parameters. +C +C ****************************************************************** +C +C .. Parameters .. +C .. CJTE is initialized to activate the calculation of J'*e .. +C .. NOUT is the unit number for printing intermediate results .. + CHARACTER CJTE + PARAMETER ( CJTE = 'C' ) + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, + $ NFEVL, NFUN +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), U(LDU,*), + $ X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST + DOUBLE PRECISION ERR +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. External Subroutines .. + EXTERNAL DAXPY, NF01AD, NF01BD +C +C .. Executable Statements .. +C + L = IPAR(2) + M = IPAR(5) + N = IPAR(6) + IF ( L.EQ.0 ) THEN + NSMP = NFUN + ELSE + NSMP = NFUN/L + END IF +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Call NF01AD to compute the output y of the Wiener system (in E) +C and then the error functions (also in E). The array U must +C contain the input to the linear part of the Wiener system, and +C Y must contain the original output Y of the Wiener system. +C IPAR(6) must contain the number of states of the linear part, n. +C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ), +C if M>0, +C NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M=0, +C where NN = IPAR(7) (number of neurons); +C prefer: larger. +C + CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, + $ NSMP, DWORK, LDWORK, INFO ) +C + DO 10 I = 1, L + CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) + 10 CONTINUE +C + DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + + $ MAX( N*(N + L), N + M + L ) ) +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Call NF01BD to compute the Jacobian in a compressed form. +C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L )), +C if M > 0, +C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), +C if M = 0; +C prefer: larger. +C + CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, + $ LDU, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) + NFEVL = IPAR(6)*( M + L + 1 ) + L*M + DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + + $ MAX( N*(N + L), N + M + L ) ) +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), and JTJ. +C + ST = IPAR(1) + BSN = IPAR(4) + NN = IPAR(7) +C + LDJ = NFUN + IPAR(1) = NFUN*( BSN + ST ) + IF ( M.GT.0 ) THEN + JWORK = MAX( N*( N + L ), N + M + L ) + ELSE + JWORK = MAX( N*( N + L ), L ) + END IF + IPAR(2) = LDJ + MAX( ( N + L )*( N + M ) + 2*N + JWORK, 2*NN ) + IPAR(3) = LDJ + IPAR(2) + IPAR(4) = 0 + IPAR(5) = NFUN +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( NFUN, E, 1 ) + WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR + END IF + RETURN +C +C *** Last line of NF01BB *** + END diff --git a/mex/sources/libslicot/NF01BD.f b/mex/sources/libslicot/NF01BD.f new file mode 100644 index 000000000..3f15bc2a6 --- /dev/null +++ b/mex/sources/libslicot/NF01BD.f @@ -0,0 +1,381 @@ + SUBROUTINE NF01BD( CJTE, NSMP, M, L, IPAR, LIPAR, X, LX, U, LDU, + $ E, J, LDJ, JTE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate the Jacobian dy/dX of the Wiener system +C +C x(t+1) = A*x(t) + B*u(t) +C z(t) = C*x(t) + D*u(t), +C +C y(t,i) = sum( ws(k, i)*f(w(k, i)*z(t) + b(k,i)) ) + b(k+1,i), +C +C where t = 1, 2, ..., NSMP, +C i = 1, 2, ..., L, +C k = 1, 2, ..., NN. +C +C NN is arbitrary eligible and has to be provided in IPAR(2), and +C X = ( wb(1), ..., wb(L), theta ) is described below. +C +C Denoting y(j) = y(1:NSMP,j), the Jacobian J has the block form +C +C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta +C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta +C ..... ..... ..... ..... ..... +C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta +C +C but it will be returned without the zero blocks, in the form +C +C dy(1)/dwb(1) dy(1)/dtheta +C ... +C dy(L)/dwb(L) dy(L)/dtheta. +C +C dy(i)/dwb(i) depends on f and is calculated by the routine NF01BY; +C dy(i)/dtheta is computed by a forward-difference approximation. +C +C ARGUMENTS +C +C Mode Parameters +C +C CJTE CHARACTER*1 +C Specifies whether the matrix-vector product J'*e should be +C computed or not, as follows: +C = 'C' : compute J'*e; +C = 'N' : do not compute J'*e. +C +C Input/Output Parameters +C +C NSMP (input) INTEGER +C The number of training samples. NSMP >= 0. +C +C M (input) INTEGER +C The length of each input sample. M >= 0. +C +C L (input) INTEGER +C The length of each output sample. L >= 0. +C +C IPAR (input/output) INTEGER array, dimension (LIPAR) +C On entry, the first entries of this array must contain +C the integer parameters needed; specifically, +C IPAR(1) must contain the order of the linear part, N; +C actually, N = abs(IPAR(1)), since setting +C IPAR(1) < 0 has a special meaning (see below); +C IPAR(2) must contain the number of neurons for the +C nonlinear part, NN, NN >= 0. +C On exit, if IPAR(1) < 0 on entry, then no computations are +C performed, except the needed tests on input parameters, +C but the following values are returned: +C IPAR(1) contains the length of the array J, LJ; +C LDJ contains the leading dimension of array J. +C Otherwise, IPAR(1) and LDJ are unchanged on exit. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 2. +C +C X (input) DOUBLE PRECISION array, dimension (LX) +C The leading LPAR entries of this array must contain the +C set of system parameters, where +C LPAR = (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. +C X has the form (wb(1), ..., wb(L), theta), where the +C vectors wb(i) have the structure +C (w(1,1), ..., w(1,L), ..., w(NN,1), ..., w(NN,L), +C ws(1), ..., ws(NN), b(1), ..., b(NN+1) ), +C and the vector theta represents the matrices A, B, C, D +C and x(1), and it can be retrieved from these matrices +C by SLICOT Library routine TB01VD and retranslated by +C TB01VY. +C +C LX (input) INTEGER +C The length of X. +C LX >= (NN*(L + 2) + 1)*L + N*(M + L + 1) + L*M. +C +C U (input) DOUBLE PRECISION array, dimension (LDU, M) +C The leading NSMP-by-M part of this array must contain the +C set of input samples, +C U = ( U(1,1),...,U(1,M); ...; U(NSMP,1),...,U(NSMP,M) ). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NSMP). +C +C E (input) DOUBLE PRECISION array, dimension (NSMP*L) +C If CJTE = 'C', this array must contain a vector e, which +C will be premultiplied with J', e = vec( Y - y ), where +C Y is set of output samples, and vec denotes the +C concatenation of the columns of a matrix. +C If CJTE = 'N', this array is not referenced. +C +C J (output) DOUBLE PRECISION array, dimension (LDJ, *) +C The leading NSMP*L-by-NCOLJ part of this array contains +C the Jacobian of the error function stored in a compressed +C form, as described above, where +C NCOLJ = NN*(L + 2) + 1 + N*(M + L + 1) + L*M. +C +C LDJ INTEGER +C The leading dimension of array J. LDJ >= MAX(1,NSMP*L). +C Note that LDJ is an input parameter, except for +C IPAR(1) < 0 on entry, when it is an output parameter. +C +C JTE (output) DOUBLE PRECISION array, dimension (LPAR) +C If CJTE = 'C', this array contains the matrix-vector +C product J'*e. +C If CJTE = 'N', this array is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ) +C if M > 0; +C LDWORK >= 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M = 0. +C A larger value of LDWORK could improve the efficiency. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C BLAS routines are used for the matrix-vector multiplications, and +C the SLICOT Library routine TB01VY is called for the conversion of +C the output normal form parameters to an LTI-system; the routine +C NF01AD is then used for the simulation of the system with given +C parameters, and the routine NF01BY is called for the (analytically +C performed) calculation of the parts referring to the parameters +C of the static nonlinearity. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Mar. 2001, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Dec. 2001. +C +C KEYWORDS +C +C Jacobian matrix, nonlinear system, output normal form, simulation, +C state-space representation, Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. +C .. EPSFCN is related to the error in computing the functions .. +C .. For EPSFCN = 0.0D0, the square root of the machine precision +C .. is used for finite difference approximation of the derivatives. + DOUBLE PRECISION ZERO, ONE, EPSFCN + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EPSFCN = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER CJTE + INTEGER INFO, L, LDJ, LDU, LDWORK, LX, LIPAR, M, NSMP +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ, *), JTE(*), U(LDU,*), + $ X(*) +C .. Local Scalars .. + LOGICAL WJTE + DOUBLE PRECISION EPS, H, PARSAV + INTEGER AC, BD, BSN, I, IX, IY, JW, K, KCOL, LDAC, LPAR, + $ LTHS, N, NN, NSML, NTHS, Z +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, NF01AD, NF01AY, NF01BY, TB01VY, + $ TF01MX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C + N = IPAR(1) + NN = IPAR(2) + BSN = NN*( L + 2 ) + 1 + NSML = NSMP*L + NTHS = BSN*L + LTHS = N*( M + L + 1 ) + L*M + LPAR = NTHS + LTHS + WJTE = LSAME( CJTE, 'C' ) +C +C Check the scalar input parameters. +C + INFO = 0 + IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( NSMP.LT.0 ) THEN + INFO = -2 + ELSEIF ( M.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.LT.0 ) THEN + INFO = -4 + ELSEIF ( NN.LT.0 ) THEN + INFO = -5 + ELSEIF ( LIPAR.LT.2 ) THEN + INFO = -6 + ELSEIF ( IPAR(1).LT.0 ) THEN + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BD', -INFO ) + ELSE + IPAR(1) = NSML*( ABS( N )*( M + L + 1 ) + L*M + BSN ) + LDJ = MAX( 1, NSML ) + ENDIF + RETURN + ELSEIF ( LX.LT.LPAR ) THEN + INFO = -8 + ELSEIF ( LDU.LT.MAX( 1, NSMP ) ) THEN + INFO = -10 + ELSEIF ( LDJ.LT.MAX( 1, NSML ) ) THEN + INFO = -13 + ELSE + LDAC = N + L + IF ( M.GT.0 ) THEN + JW = MAX( N*LDAC, N + M + L ) + ELSE + JW = MAX( N*LDAC, L ) + END IF + IF ( LDWORK.LT.2*NSML + MAX( 2*NN, LDAC*( N + M ) + 2*N + JW )) + $ INFO = -16 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MIN( NSMP, L ).EQ.0 ) THEN + IF ( WJTE .AND. LPAR.GE.1 ) THEN + JTE(1) = ZERO + CALL DCOPY( LPAR, JTE(1), 0, JTE(1), 1 ) + END IF + RETURN + END IF +C +C Compute the output of the linear part. +C Workspace: need 2*NSMP*L + (N + L)*(N + M) + N + N*(N + L + 1). +C (2*NSMP*L locations are reserved for computing two times the +C output of the linear part.) +C + IY = 1 + Z = IY + NSML + AC = Z + NSML + BD = AC + LDAC*N + IX = BD + LDAC*M + JW = IX + N +C + CALL TB01VY( 'Apply', N, M, L, X(NTHS+1), LTHS, DWORK(AC), LDAC, + $ DWORK(BD), LDAC, DWORK(AC+N), LDAC, DWORK(BD+N), + $ LDAC, DWORK(IX), DWORK(JW), LDWORK-JW+1, INFO ) +C +C Workspace: need 2*NSMP*L + (N + L)*(N + M) + 3*N + M + L, +C if M > 0; +C 2*NSMP*L + (N + L)*N + 2*N + L, if M = 0; +C prefer larger. +C + CALL TF01MX( N, M, L, NSMP, DWORK(AC), LDAC, U, LDU, DWORK(IX), + $ DWORK(Z), NSMP, DWORK(JW), LDWORK-JW+1, INFO ) +C +C Fill the blocks dy(i)/dwb(i) and the corresponding parts of JTE, +C if needed. +C + JW = AC + IF ( WJTE ) THEN +C + DO 10 I = 0, L - 1 + CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), + $ BSN, DWORK(Z), NSMP, E(I*NSMP+1), + $ J(I*NSMP+1,1), LDJ, JTE(I*BSN+1), DWORK(JW), + $ LDWORK-JW+1, INFO ) + 10 CONTINUE +C + ELSE +C + DO 20 I = 0, L - 1 + CALL NF01BY( CJTE, NSMP, L, 1, IPAR(2), LIPAR-1, X(I*BSN+1), + $ BSN, DWORK(Z), NSMP, DWORK, J(I*NSMP+1,1), LDJ, + $ DWORK, DWORK(JW), LDWORK-JW+1, INFO ) + 20 CONTINUE +C + END IF +C +C Compute the output of the system with unchanged parameters. +C Workspace: need 2*NSMP*L + 2*NN; +C prefer larger. +C + CALL NF01AY( NSMP, L, L, IPAR(2), LIPAR-1, X, NTHS, DWORK(Z), + $ NSMP, DWORK(IY), NSMP, DWORK(JW), LDWORK-JW+1, + $ INFO ) +C +C Compute dy/dtheta numerically by forward-difference approximation. +C Workspace: need 2*NSMP*L + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ), +C if M > 0; +C 2*NSMP*L + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M = 0; +C prefer larger. +C + JW = Z + EPS = SQRT( MAX( EPSFCN, DLAMCH( 'Epsilon' ) ) ) +C + DO 40 K = NTHS + 1, LPAR + KCOL = K - NTHS + BSN + PARSAV = X(K) + IF ( PARSAV.EQ.ZERO ) THEN + H = EPS + ELSE + H = EPS*ABS( PARSAV ) + END IF + X(K) = X(K) + H + CALL NF01AD( NSMP, M, L, IPAR, LIPAR, X, LPAR, U, LDU, + $ J(1,KCOL), NSMP, DWORK(JW), LDWORK-JW+1, + $ INFO ) + X(K) = PARSAV +C + DO 30 I = 1, NSML + J(I,KCOL) = ( J(I,KCOL) - DWORK(I) ) / H + 30 CONTINUE +C + 40 CONTINUE +C + IF ( WJTE ) THEN +C +C Compute the last part of J'e in JTE. +C + CALL DGEMV( 'Transpose', NSML, LTHS, ONE, J(1,BSN+1), LDJ, E, + $ 1, ZERO, JTE(NTHS+1), 1 ) + END IF +C + RETURN +C +C *** Last line of NF01BD *** + END diff --git a/mex/sources/libslicot/NF01BE.f b/mex/sources/libslicot/NF01BE.f new file mode 100644 index 000000000..a9ad1dde5 --- /dev/null +++ b/mex/sources/libslicot/NF01BE.f @@ -0,0 +1,105 @@ + SUBROUTINE NF01BE( IFLAG, NSMP, N, IPAR, LIPAR, Z, LDZ, Y, LDY, X, + $ NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for optimizing the parameters of the +C nonlinear part of a Wiener system (initialization phase), using +C SLICOT Library routine MD03BD. See the argument FCN in the +C routine MD03BD for the description of parameters. Note that +C NF01BE is called for each output of the Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. +C .. CJTE is initialized to avoid the calculation of J'*e .. +C .. NOUT is the unit number for printing intermediate results .. + CHARACTER CJTE + PARAMETER ( CJTE = 'N' ) + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDWORK, LDY, LDZ, LIPAR, N, + $ NFEVL, NSMP +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), X(*), Y(LDY,*), + $ Z(LDZ,*) +C .. Local Scalars .. + DOUBLE PRECISION ERR +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. External Subroutines .. + EXTERNAL DAXPY, NF01AY, NF01BY +C +C .. Executable Statements .. +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Call NF01AY to compute the output y of the Wiener system (in E) +C and then the error functions (also in E). The array Z must +C contain the output of the linear part of the Wiener system, and +C Y must contain the original output Y of the Wiener system. +C IPAR(2) must contain the number of outputs. +C Workspace: need: 2*NN, NN = IPAR(3) (number of neurons); +C prefer: larger. +C + CALL NF01AY( NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, LDZ, + $ E, NSMP, DWORK, LDWORK, INFO ) + CALL DAXPY( NSMP, -ONE, Y, 1, E, 1 ) + DWORK(1) = 2*IPAR(3) +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Call NF01BY to compute the Jacobian in a compressed form. +C IPAR(2), IPAR(3) must have the same content as for IFLAG = 1. +C Workspace: need: 0. +C + CALL NF01BY( CJTE, NSMP, IPAR(2), 1, IPAR(3), LIPAR-2, X, N, Z, + $ LDZ, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) + NFEVL = 0 + DWORK(1) = ZERO +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. +C + LDJ = NSMP + IPAR(1) = NSMP*N + IPAR(2) = 2*IPAR(3) + IPAR(3) = 0 + IPAR(4) = 4*N + 1 + IPAR(5) = 4*N +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( NSMP, E, 1 ) + WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR + END IF + RETURN +C +C *** Last line of NF01BE *** + END diff --git a/mex/sources/libslicot/NF01BF.f b/mex/sources/libslicot/NF01BF.f new file mode 100644 index 000000000..d47b288dc --- /dev/null +++ b/mex/sources/libslicot/NF01BF.f @@ -0,0 +1,157 @@ + SUBROUTINE NF01BF( IFLAG, NFUN, LX, IPAR, LIPAR, U, LDU, Y, LDY, + $ X, NFEVL, E, J, LDJ, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C This is the FCN routine for optimizing all parameters of a Wiener +C system using SLICOT Library routine MD03BD. See the argument FCN +C in the routine MD03BD for the description of parameters. +C +C ****************************************************************** +C +C .. Parameters .. +C .. CJTE is initialized to avoid the calculation of J'*e .. +C .. NOUT is the unit number for printing intermediate results .. + CHARACTER CJTE + PARAMETER ( CJTE = 'N' ) + INTEGER NOUT + PARAMETER ( NOUT = 6 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IFLAG, INFO, LDJ, LDU, LDWORK, LDY, LIPAR, LX, + $ NFEVL, NFUN +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), U(LDU,*), X(*), + $ Y(LDY,*) +C .. Local Scalars .. + LOGICAL FULL + INTEGER BSN, I, JWORK, L, M, N, NN, NSMP, ST + DOUBLE PRECISION ERR +C .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +C .. External Subroutines .. + EXTERNAL DAXPY, NF01AD, NF01BD +C +C .. Executable Statements .. +C + L = IPAR(2) + M = IPAR(5) + N = IPAR(6) + IF ( L.EQ.0 ) THEN + NSMP = NFUN + ELSE + NSMP = NFUN/L + END IF +C + INFO = 0 + IF ( IFLAG.EQ.1 ) THEN +C +C Call NF01AD to compute the output y of the Wiener system (in E) +C and then the error functions (also in E). The array U must +C contain the input to the linear part of the Wiener system, and +C Y must contain the original output Y of the Wiener system. +C IPAR(6) must contain the number of states of the linear part, n. +C Workspace: need: NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L ) ), +C if M>0, +C NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), if M=0, +C where NN = IPAR(7) (number of neurons); +C prefer: larger. +C + CALL NF01AD( NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, LDU, E, + $ NSMP, DWORK, LDWORK, INFO ) +C + DO 10 I = 1, L + CALL DAXPY( NSMP, -ONE, Y(1,I), 1, E((I-1)*NSMP+1), 1 ) + 10 CONTINUE +C + DWORK(1) = NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + + $ MAX( N*(N + L), N + M + L ) ) +C + ELSE IF ( IFLAG.EQ.2 ) THEN +C +C Call NF01BD to compute the Jacobian in a compressed form. +C Workspace: need: 2*NFUN + MAX( 2*NN, (N + L)*(N + M) + 2*N + +C MAX( N*(N + L), N + M + L )), +C if M > 0, +C 2*NFUN + MAX( 2*NN, (N + L)*N + 2*N + +C MAX( N*(N + L), L ) ), +C if M > 0; +C prefer: larger. +C + CALL NF01BD( CJTE, NSMP, M, L, IPAR(6), LIPAR-2, X, LX, U, + $ LDU, E, J, LDJ, DWORK, DWORK, LDWORK, INFO ) + NFEVL = IPAR(6)*( M + L + 1 ) + L*M + DWORK(1) = 2*NFUN + MAX( 2*IPAR(7), (N + L)*(N + M) + 2*N + + $ MAX( N*(N + L), N + M + L ) ) +C + ELSE IF ( IFLAG.EQ.3 ) THEN +C +C Set the parameter LDJ, the length of the array J, and the sizes +C of the workspace for FCN (IFLAG = 1 or 2), QRFACT and LMPARM. +C Condition estimation (COND = 'E') is assumed in these routines. +C + ST = IPAR(1) + BSN = IPAR(4) + NN = IPAR(7) + FULL = L.LE.1 .OR. BSN.EQ.0 +C + LDJ = NFUN + IPAR(1) = LDJ*( BSN + ST ) + IF ( M.GT.0 ) THEN + JWORK = MAX( N*( N + L ), N + M + L ) + ELSE + JWORK = MAX( N*( N + L ), L ) + END IF + IPAR(2) = LDJ + MAX( (N + L)*(N + M) + 2*N + JWORK, 2*NN ) + IPAR(3) = LDJ + IPAR(2) + JWORK = 1 + IF ( FULL ) THEN + JWORK = 4*LX + 1 + ELSEIF ( BSN.GT.0 ) THEN + JWORK = BSN + MAX( 3*BSN + 1, ST ) + IF ( NSMP.GT.BSN ) THEN + JWORK = MAX( JWORK, 4*ST + 1 ) + IF ( NSMP.LT.2*BSN ) + $ JWORK = MAX( JWORK, ( NSMP - BSN )*( L - 1 ) ) + END IF + END IF + IPAR(4) = JWORK + IF ( FULL ) THEN + JWORK = 4*LX + ELSE + JWORK = ST*( LX - ST ) + 2*LX + 2*MAX( BSN, ST ) + END IF + IPAR(5) = JWORK +C + ELSE IF ( IFLAG.EQ.0 ) THEN +C +C Special call for printing intermediate results. +C + ERR = DNRM2( NFUN, E, 1 ) + WRITE( NOUT, '('' Norm of current error = '', D15.6)') ERR + END IF + RETURN +C +C *** Last line of NF01BF *** + END diff --git a/mex/sources/libslicot/NF01BP.f b/mex/sources/libslicot/NF01BP.f new file mode 100644 index 000000000..e15e17f4e --- /dev/null +++ b/mex/sources/libslicot/NF01BP.f @@ -0,0 +1,666 @@ + SUBROUTINE NF01BP( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, + $ DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a value for the Levenberg-Marquardt parameter PAR +C such that if x solves the system +C +C J*x = b , sqrt(PAR)*D*x = 0 , +C +C in the least squares sense, where J is an m-by-n matrix, D is an +C n-by-n nonsingular diagonal matrix, and b is an m-vector, and if +C DELTA is a positive number, DXNORM is the Euclidean norm of D*x, +C then either PAR is zero and +C +C ( DXNORM - DELTA ) .LE. 0.1*DELTA , +C +C or PAR is positive and +C +C ABS( DXNORM - DELTA ) .LE. 0.1*DELTA . +C +C The matrix J is the current Jacobian matrix of a nonlinear least +C squares problem, provided in a compressed form by SLICOT Library +C routine NF01BD. It is assumed that a block QR factorization, with +C column pivoting, of J is available, that is, J*P = Q*R, where P is +C a permutation matrix, Q has orthogonal columns, and R is an upper +C triangular matrix with diagonal elements of nonincreasing +C magnitude for each block, as returned by SLICOT Library +C routine NF01BS. The routine NF01BP needs the upper triangle of R +C in compressed form, the permutation matrix P, and the first +C n components of Q'*b (' denotes the transpose). On output, +C NF01BP also provides a compressed representation of an upper +C triangular matrix S, such that +C +C P'*(J'*J + PAR*D*D)*P = S'*S . +C +C Matrix S is used in the solution process. The matrix R has the +C following structure +C +C / R_1 0 .. 0 | L_1 \ +C | 0 R_2 .. 0 | L_2 | +C | : : .. : | : | , +C | 0 0 .. R_l | L_l | +C \ 0 0 .. 0 | R_l+1 / +C +C where the submatrices R_k, k = 1:l, have the same order BSN, +C and R_k, k = 1:l+1, are square and upper triangular. This matrix +C is stored in the compressed form +C +C / R_1 | L_1 \ +C | R_2 | L_2 | +C Rc = | : | : | , +C | R_l | L_l | +C \ X | R_l+1 / +C +C where the submatrix X is irrelevant. The matrix S has the same +C structure as R, and its diagonal blocks are denoted by S_k, +C k = 1:l+1. +C +C If l <= 1, then the full upper triangle of the matrix R is stored. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the diagonal blocks R_k +C and S_k of the matrices R and S should be estimated, +C as follows: +C = 'E' : use incremental condition estimation for each +C diagonal block of R_k and S_k to find its +C numerical rank; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of R_k and S_k for zero values; +C = 'U' : use the ranks already stored in RANKS (for R). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N = BN*BSN + ST >= 0. +C (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix R, as follows: +C IPAR(1) must contain ST, the number of columns of the +C submatrices L_k and the order of R_l+1. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, l, in the +C block diagonal part of R. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C R_k, k = 1:l. BSM >= 0. +C IPAR(4) must contain BSN, the number of columns of the +C blocks R_k, k = 1:l. BSN >= 0. +C BSM is not used by this routine, but assumed equal to BSN. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C On entry, the leading N-by-NC part of this array must +C contain the (compressed) representation (Rc) of the upper +C triangular matrix R. If BN > 1, the submatrix X in Rc is +C not referenced. The zero strict lower triangles of R_k, +C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then +C the full upper triangle of R must be stored. +C On exit, the full upper triangles of R_k, k = 1:l+1, and +C L_k, k = 1:l, are unaltered, and the strict lower +C triangles of R_k, k = 1:l+1, contain the corresponding +C strict upper triangles (transposed) of the upper +C triangular matrix S. +C If BN <= 1 or BSN = 0, then the transpose of the strict +C upper triangle of S is stored in the strict lower triangle +C of R. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. DIAG(I) <> 0, I = 1,...,N. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C DELTA (input) DOUBLE PRECISION +C An upper bound on the Euclidean norm of D*x. DELTA > 0. +C +C PAR (input/output) DOUBLE PRECISION +C On entry, PAR must contain an initial estimate of the +C Levenberg-Marquardt parameter. PAR >= 0. +C On exit, it contains the final estimate of this parameter. +C +C RANKS (input or output) INTEGER array, dimension (r), where +C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; +C r = BN, if ST = 0 and BSN > 0; +C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); +C r = 0, if ST = 0 and BSN = 0. +C On entry, if COND = 'U' and N > 0, this array must contain +C the numerical ranks of the submatrices R_k, k = 1:l(+1). +C On exit, if N > 0, this array contains the numerical ranks +C of the submatrices S_k, k = 1:l(+1). +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system J*x = b, sqrt(PAR)*D*x = 0. +C +C RX (output) DOUBLE PRECISION array, dimension (N) +C This array contains the matrix-vector product -R*P'*x. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C ranks of the submatrices R_k and S_k. If the user sets +C TOL > 0, then the given value of TOL is used as a lower +C bound for the reciprocal condition number; a (sub)matrix +C whose estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S. +C If BN > 1 and BSN > 0, the elements N+1 : N+ST*(N-ST) +C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the +C matrix S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and +C COND <> 'E'; +C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and +C COND = 'E'; +C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and +C COND <> 'E'; +C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), +C if BN > 1 and BSN > 0 and +C COND = 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The algorithm computes the Gauss-Newton direction. An approximate +C basic least squares solution is found if the Jacobian is rank +C deficient. The computations exploit the special structure and +C storage scheme of the matrix R. If one or more of the submatrices +C R_k or S_k, k = 1:l+1, is singular, then the computed result is +C not the basic least squares solution for the whole problem, but a +C concatenation of (least squares) solutions of the individual +C subproblems involving R_k or S_k, k = 1:l+1 (with adapted right +C hand sides). +C +C If the Gauss-Newton direction is not acceptable, then an iterative +C algorithm obtains improved lower and upper bounds for the +C Levenberg-Marquardt parameter PAR. Only a few iterations are +C generally needed for convergence of the algorithm. If, however, +C the limit of ITMAX = 10 iterations is reached, then the output PAR +C will contain the best value obtained so far. If the Gauss-Newton +C step is acceptable, it is stored in x, and PAR is set to zero, +C hence S = R. +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(N*(BSN+ST)) operations and is backward +C stable, if R is nonsingular. +C +C FURTHER COMMENTS +C +C This routine is a structure-exploiting, LAPACK-based modification +C of LMPAR from the MINPACK package [1], and with optional condition +C estimation. The option COND = 'U' is useful when dealing with +C several right-hand side vectors, but RANKS array should be reset. +C If COND = 'E', but the matrix S is guaranteed to be nonsingular +C and well conditioned relative to TOL, i.e., rank(R) = N, and +C min(DIAG) > 0, then its condition is not estimated. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Feb. 2004. +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER ITMAX + PARAMETER ( ITMAX = 10 ) + DOUBLE PRECISION P1, P001, ZERO, ONE + PARAMETER ( P1 = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0, + $ ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, LIPAR, N + DOUBLE PRECISION DELTA, PAR, TOL +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*), RANKS(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*) +C .. Local Scalars .. + INTEGER BN, BSM, BSN, I, IBSN, ITER, J, JW, K, L, LDS, + $ N2, NTHS, RANK, ST + DOUBLE PRECISION DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL, + $ PARU, SUM, TEMP, TOLDEF + LOGICAL BADRK, ECOND, NCOND, SING, UCOND + CHARACTER CONDL +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DTRMV, MD03BY, NF01BQ, NF01BR, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + NCOND = LSAME( COND, 'N' ) + UCOND = LSAME( COND, 'U' ) + INFO = 0 + N2 = 2*N + IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN + INFO = -1 + ELSEIF( N.LT.0 ) THEN + INFO = -2 + ELSEIF( LIPAR.LT.4 ) THEN + INFO = -4 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF( DELTA.LE.ZERO ) THEN + INFO = -10 + ELSEIF( PAR.LT.ZERO ) THEN + INFO = -11 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -3 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -2 + ELSE + IF ( N.GT.0 ) + $ DMINO = DIAG(1) + SING = .FALSE. +C + DO 10 J = 1, N + IF ( DIAG(J).LT.DMINO ) + $ DMINO = DIAG(J) + SING = SING .OR. DIAG(J).EQ.ZERO + 10 CONTINUE +C + IF ( SING ) THEN + INFO = -8 + ELSEIF ( UCOND ) THEN + BADRK = .FALSE. + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN + IF ( N.GT.0 ) + $ BADRK = RANKS(1).LT.0 .OR. RANKS(1).GT.N + ELSE + RANK = 0 +C + DO 20 K = 1, BN + BADRK = BADRK .OR. RANKS(K).LT.0 + $ .OR. RANKS(K).GT.BSN + RANK = RANK + RANKS(K) + 20 CONTINUE +C + IF ( ST.GT.0 ) THEN + BADRK = BADRK .OR. RANKS(BN+1).LT.0 .OR. + $ RANKS(BN+1).GT.ST + RANK = RANK + RANKS(BN+1) + END IF + END IF + IF ( BADRK ) + $ INFO = -12 + ELSE + JW = N2 + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN + IF ( ECOND ) + $ JW = 4*N + ELSE + JW = ST*NTHS + JW + IF ( ECOND ) + $ JW = 2*MAX( BSN, ST ) + JW + END IF + IF ( LDWORK.LT.JW ) + $ INFO = -17 + ENDIF + ENDIF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BP', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + PAR = ZERO + RETURN + END IF +C + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN +C +C Special case: R is just an upper triangular matrix. +C Workspace: 4*N, if COND = 'E'; +C 2*N, if COND <> 'E'. +C + CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR, + $ RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO ) + RETURN + END IF +C +C General case: l > 1 and BSN > 0. +C DWARF is the smallest positive magnitude. +C + DWARF = DLAMCH( 'Underflow' ) +C +C Compute and store in x the Gauss-Newton direction. If the +C Jacobian is rank-deficient, obtain a least squares solution. +C The array RX is used as workspace. +C Workspace: 2*MAX(BSN,ST), if COND = 'E'; +C 0, if COND <> 'E'. +C + CALL DCOPY( N, QTB, 1, RX, 1 ) + CALL NF01BR( COND, 'Upper', 'No transpose', N, IPAR, LIPAR, R, + $ LDR, DWORK, DWORK, 1, RX, RANKS, TOL, DWORK, LDWORK, + $ INFO ) +C + DO 30 J = 1, N + L = IPVT(J) + X(L) = RX(J) + 30 CONTINUE +C +C Initialize the iteration counter. +C Evaluate the function at the origin, and test +C for acceptance of the Gauss-Newton direction. +C + ITER = 0 +C + DO 40 J = 1, N + DWORK(J) = DIAG(J)*X(J) + 40 CONTINUE +C + DXNORM = DNRM2( N, DWORK, 1 ) + FP = DXNORM - DELTA + IF ( FP.GT.P1*DELTA ) THEN +C +C Set an appropriate option for estimating the condition of +C the matrix S. +C + LDS = MAX( 1, ST ) + JW = N2 + ST*NTHS + IF ( UCOND ) THEN + IF ( LDWORK.GE.JW + 2*MAX( BSN, ST ) ) THEN + CONDL = 'E' + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + ELSE + CONDL = 'N' + TOLDEF = TOL + END IF + ELSE + RANK = 0 +C + DO 50 K = 1, BN + RANK = RANK + RANKS(K) + 50 CONTINUE +C + IF ( ST.GT.0 ) + $ RANK = RANK + RANKS(BN+1) + CONDL = COND + TOLDEF = TOL + END IF +C +C If the Jacobian is not rank deficient, the Newton +C step provides a lower bound, PARL, for the zero of +C the function. Otherwise set this bound to zero. +C + IF ( RANK.EQ.N ) THEN +C + DO 60 J = 1, N + L = IPVT(J) + RX(J) = DIAG(L)*( DWORK(L)/DXNORM ) + 60 CONTINUE +C + CALL NF01BR( 'Use ranks', 'Upper', 'Transpose', N, IPAR, + $ LIPAR, R, LDR, DWORK, DWORK, 1, RX, RANKS, TOL, + $ DWORK, LDWORK, INFO ) + TEMP = DNRM2( N, RX, 1 ) + PARL = ( ( FP/DELTA )/TEMP )/TEMP +C +C For efficiency, use CONDL = 'U', if possible. +C + IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO ) + $ CONDL = 'U' + ELSE + PARL = ZERO + END IF +C + IBSN = 0 + K = 1 +C +C Calculate an upper bound, PARU, for the zero of the function. +C + DO 70 J = 1, N + IBSN = IBSN + 1 + IF ( J.LT.NTHS ) THEN + SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) + IF ( IBSN.EQ.BSN ) THEN + IBSN = 0 + K = K + BSN + END IF + ELSE IF ( J.EQ.NTHS ) THEN + SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 ) + ELSE + SUM = DDOT( J, R(1,IBSN), 1, QTB, 1 ) + END IF + L = IPVT(J) + RX(J) = SUM/DIAG(L) + 70 CONTINUE +C + GNORM = DNRM2( N, RX, 1 ) + PARU = GNORM/DELTA + IF ( PARU.EQ.ZERO ) + $ PARU = DWARF/MIN( DELTA, P1 )/P001 +C +C If the input PAR lies outside of the interval (PARL,PARU), +C set PAR to the closer endpoint. +C + PAR = MAX( PAR, PARL ) + PAR = MIN( PAR, PARU ) + IF ( PAR.EQ.ZERO ) + $ PAR = GNORM/DXNORM +C +C Beginning of an iteration. +C + 80 CONTINUE + ITER = ITER + 1 +C +C Evaluate the function at the current value of PAR. +C + IF ( PAR.EQ.ZERO ) + $ PAR = MAX( DWARF, P001*PARU ) + TEMP = SQRT( PAR ) +C + DO 90 J = 1, N + RX(J) = TEMP*DIAG(J) + 90 CONTINUE +C +C Solve the system J*x = b , sqrt(PAR)*D*x = 0 , in a least +C square sense. +C The first N elements of DWORK contain the diagonal elements +C of the upper triangular matrix S, and the next N elements +C contain the the vector z, so that x = P*z (see NF01BQ). +C The vector z is not preserved, to reduce the workspace. +C The elements 2*N+1 : 2*N+ST*(N-ST) contain the +C submatrix (S(1:N-ST,N-ST+1:N))' of the matrix S. +C Workspace: ST*(N-ST) + 2*N, if CONDL <> 'E'; +C ST*(N-ST) + 2*N + 2*MAX(BSN,ST), if CONDL = 'E'. +C + CALL NF01BQ( CONDL, N, IPAR, LIPAR, R, LDR, IPVT, RX, QTB, + $ RANKS, X, TOLDEF, DWORK, LDWORK, INFO ) +C + DO 100 J = 1, N + DWORK(N+J) = DIAG(J)*X(J) + 100 CONTINUE +C + DXNORM = DNRM2( N, DWORK(N+1), 1 ) + TEMP = FP + FP = DXNORM - DELTA +C +C If the function is small enough, accept the current value +C of PAR. Also test for the exceptional cases where PARL +C is zero or the number of iterations has reached ITMAX. +C + IF ( ABS( FP ).GT.P1*DELTA .AND. + $ ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND. + $ ITER.LT.ITMAX ) THEN +C +C Compute the Newton correction. +C + DO 110 J = 1, N + L = IPVT(J) + RX(J) = DIAG(L)*( DWORK(N+L)/DXNORM ) + 110 CONTINUE +C + CALL NF01BR( 'Use ranks', 'Lower', 'Transpose', N, IPAR, + $ LIPAR, R, LDR, DWORK, DWORK(N2+1), LDS, RX, + $ RANKS, TOL, DWORK(JW), LDWORK-JW, INFO ) + TEMP = DNRM2( N, RX, 1 ) + PARC = ( ( FP/DELTA )/TEMP )/TEMP +C +C Depending on the sign of the function, update PARL +C or PARU. +C + IF ( FP.GT.ZERO ) THEN + PARL = MAX( PARL, PAR ) + ELSE IF ( FP.LT.ZERO ) THEN + PARU = MIN( PARU, PAR ) + END IF +C +C Compute an improved estimate for PAR. +C + PAR = MAX( PARL, PAR + PARC ) +C +C End of an iteration. +C + GO TO 80 + END IF + END IF +C +C Compute -R*P'*x = -R*z. +C + DO 120 J = 1, N + L = IPVT(J) + RX(J) = -X(L) + 120 CONTINUE +C + DO 130 I = 1, NTHS, BSN + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', BSN, R(I,1), + $ LDR, RX(I), 1 ) + 130 CONTINUE +C + IF ( ST.GT.0 ) THEN + CALL DGEMV( 'NoTranspose', NTHS, ST, ONE, R(1,BSN+1), LDR, + $ RX(NTHS+1), 1, ONE, RX, 1 ) + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', ST, + $ R(NTHS+1,BSN+1), LDR, RX(NTHS+1), 1 ) + END IF +C +C Termination. If PAR = 0, set S. +C + IF ( ITER.EQ.0 ) THEN + PAR = ZERO + I = 1 +C + DO 150 K = 1, BN +C + DO 140 J = 1, BSN + DWORK(I) = R(I,J) + CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 140 CONTINUE +C + 150 CONTINUE +C + IF ( ST.GT.0 ) THEN +C + DO 160 J = BSN + 1, BSN + ST + CALL DCOPY( NTHS, R(1,J), 1, DWORK(N+J-BSN), ST ) + DWORK(I) = R(I,J) + CALL DCOPY( BSN+ST-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 160 CONTINUE +C + END IF + ELSE +C + DO 170 K = N + 1, N + ST*NTHS + DWORK(K) = DWORK(K+N) + 170 CONTINUE +C + END IF +C + RETURN +C +C *** Last line of NF01BP *** + END diff --git a/mex/sources/libslicot/NF01BQ.f b/mex/sources/libslicot/NF01BQ.f new file mode 100644 index 000000000..e07faaa28 --- /dev/null +++ b/mex/sources/libslicot/NF01BQ.f @@ -0,0 +1,477 @@ + SUBROUTINE NF01BQ( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB, + $ RANKS, X, TOL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine a vector x which solves the system of linear +C equations +C +C J*x = b , D*x = 0 , +C +C in the least squares sense, where J is an m-by-n matrix, +C D is an n-by-n diagonal matrix, and b is an m-vector. The matrix J +C is the current Jacobian of a nonlinear least squares problem, +C provided in a compressed form by SLICOT Library routine NF01BD. +C It is assumed that a block QR factorization, with column pivoting, +C of J is available, that is, J*P = Q*R, where P is a permutation +C matrix, Q has orthogonal columns, and R is an upper triangular +C matrix with diagonal elements of nonincreasing magnitude for each +C block, as returned by SLICOT Library routine NF01BS. The routine +C NF01BQ needs the upper triangle of R in compressed form, the +C permutation matrix P, and the first n components of Q'*b +C (' denotes the transpose). The system J*x = b, D*x = 0, is then +C equivalent to +C +C R*z = Q'*b , P'*D*P*z = 0 , (1) +C +C where x = P*z. If this system does not have full rank, then an +C approximate least squares solution is obtained (see METHOD). +C On output, NF01BQ also provides an upper triangular matrix S +C such that +C +C P'*(J'*J + D*D)*P = S'*S . +C +C The system (1) is equivalent to S*z = c , where c contains the +C first n components of the vector obtained by applying to +C [ (Q'*b)' 0 ]' the transformations which triangularized +C [ R' P'*D*P ]', getting S. +C +C The matrix R has the following structure +C +C / R_1 0 .. 0 | L_1 \ +C | 0 R_2 .. 0 | L_2 | +C | : : .. : | : | , +C | 0 0 .. R_l | L_l | +C \ 0 0 .. 0 | R_l+1 / +C +C where the submatrices R_k, k = 1:l, have the same order BSN, +C and R_k, k = 1:l+1, are square and upper triangular. This matrix +C is stored in the compressed form +C +C / R_1 | L_1 \ +C | R_2 | L_2 | +C Rc = | : | : | , +C | R_l | L_l | +C \ X | R_l+1 / +C +C where the submatrix X is irrelevant. The matrix S has the same +C structure as R, and its diagonal blocks are denoted by S_k, +C k = 1:l+1. +C +C If l <= 1, then the full upper triangle of the matrix R is stored. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of the matrices S_k should +C be estimated, as follows: +C = 'E' : use incremental condition estimation and store +C the numerical rank of S_k in the array entry +C RANKS(k), for k = 1:l+1; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of S_k for zero values; +C = 'U' : use the ranks already stored in RANKS(1:l+1). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N = BN*BSN + ST >= 0. +C (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix R, as follows: +C IPAR(1) must contain ST, the number of columns of the +C submatrices L_k and the order of R_l+1. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, l, in the +C block diagonal part of R. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C R_k, k = 1:l. BSM >= 0. +C IPAR(4) must contain BSN, the number of columns of the +C blocks R_k, k = 1:l. BSN >= 0. +C BSM is not used by this routine, but assumed equal to BSN. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C On entry, the leading N-by-NC part of this array must +C contain the (compressed) representation (Rc) of the upper +C triangular matrix R. If BN > 1, the submatrix X in Rc is +C not referenced. The zero strict lower triangles of R_k, +C k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then +C the full upper triangle of R must be stored. +C On exit, the full upper triangles of R_k, k = 1:l+1, and +C L_k, k = 1:l, are unaltered, and the strict lower +C triangles of R_k, k = 1:l+1, contain the corresponding +C strict upper triangles (transposed) of the upper +C triangular matrix S. +C If BN <= 1 or BSN = 0, then the transpose of the strict +C upper triangle of S is stored in the strict lower triangle +C of R. +C +C LDR INTEGER +C The leading dimension of the array R. LDR >= MAX(1,N). +C +C IPVT (input) INTEGER array, dimension (N) +C This array must define the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C DIAG (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the diagonal elements of the +C matrix D. +C +C QTB (input) DOUBLE PRECISION array, dimension (N) +C This array must contain the first n elements of the +C vector Q'*b. +C +C RANKS (input or output) INTEGER array, dimension (r), where +C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; +C r = BN, if ST = 0 and BSN > 0; +C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); +C r = 0, if ST = 0 and BSN = 0. +C On entry, if COND = 'U' and N > 0, this array must contain +C the numerical ranks of the submatrices S_k, k = 1:l(+1). +C On exit, if COND = 'E' or 'N' and N > 0, this array +C contains the numerical ranks of the submatrices S_k, +C k = 1:l(+1), estimated according to the value of COND. +C +C X (output) DOUBLE PRECISION array, dimension (N) +C This array contains the least squares solution of the +C system J*x = b, D*x = 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C ranks of the submatrices S_k. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C the reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, the first N elements of this array contain the +C diagonal elements of the upper triangular matrix S, and +C the next N elements contain the solution z. +C If BN > 1 and BSN > 0, the elements 2*N+1 : 2*N+ST*(N-ST) +C contain the submatrix (S(1:N-ST,N-ST+1:N))' of the +C matrix S. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*N, if BN <= 1 or BSN = 0 and +C COND <> 'E'; +C LDWORK >= 4*N, if BN <= 1 or BSN = 0 and +C COND = 'E'; +C LDWORK >= ST*(N-ST) + 2*N, if BN > 1 and BSN > 0 and +C COND <> 'E'; +C LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST), +C if BN > 1 and BSN > 0 and +C COND = 'E'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Standard plane rotations are used to annihilate the elements of +C the diagonal matrix D, updating the upper triangular matrix R +C and the first n elements of the vector Q'*b. A basic least squares +C solution is computed. The computations exploit the special +C structure and storage scheme of the matrix R. If one or more of +C the submatrices S_k, k = 1:l+1, is singular, then the computed +C result is not the basic least squares solution for the whole +C problem, but a concatenation of (least squares) solutions of the +C individual subproblems involving R_k, k = 1:l+1 (with adapted +C right hand sides). +C +C REFERENCES +C +C [1] More, J.J., Garbow, B.S, and Hillstrom, K.E. +C User's Guide for MINPACK-1. +C Applied Math. Division, Argonne National Laboratory, Argonne, +C Illinois, Report ANL-80-74, 1980. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(N*(BSN+ST)) operations and is backward +C stable, if R is nonsingular. +C +C FURTHER COMMENTS +C +C This routine is a structure-exploiting, LAPACK-based modification +C of QRSOLV from the MINPACK package [1], and with optional +C condition estimation. +C The option COND = 'U' is useful when dealing with several +C right-hand side vectors. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND + INTEGER INFO, LDR, LDWORK, LIPAR, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*), RANKS(*) + DOUBLE PRECISION DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*) +C .. Local Scalars .. + DOUBLE PRECISION QTBPJ + INTEGER BN, BSM, BSN, I, IB, IBSN, IS, ITC, ITR, J, + $ JW, K, KF, L, NC, NTHS, ST + LOGICAL ECOND +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, MB02YD, MB04OW, NF01BR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + INFO = 0 + IF( .NOT.( ECOND .OR. LSAME( COND, 'N' ) .OR. + $ LSAME( COND, 'U' ) ) ) THEN + INFO = -1 + ELSEIF( N.LT.0 ) THEN + INFO = -2 + ELSEIF( LIPAR.LT.4 ) THEN + INFO = -4 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -3 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -2 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + JW = 2*N + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN + IF ( ECOND ) + $ JW = 4*N + ELSE + JW = ST*NTHS + JW + IF ( ECOND ) + $ JW = 2*MAX( BSN, ST ) + JW + END IF + IF ( LDWORK.LT.JW ) + $ INFO = -14 + ENDIF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BQ', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN +C +C Special case: R is an upper triangular matrix. +C Workspace: 4*N, if COND = 'E'; +C 2*N, if COND <> 'E'. +C + CALL MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANKS(1), X, + $ TOL, DWORK, LDWORK, INFO ) + RETURN + END IF +C +C General case: BN > 1 and BSN > 0. +C Copy R and Q'*b to preserve input and initialize S. +C In particular, save the diagonal elements of R in X. +C + IB = N + 1 + IS = IB + N + JW = IS + ST*NTHS + I = 1 + L = IS + NC = BSN + ST + KF = NC +C + DO 20 K = 1, BN +C + DO 10 J = 1, BSN + X(I) = R(I,J) + CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 10 CONTINUE +C + 20 CONTINUE +C +C DWORK(IS) contains a copy of [ L_1' ... L_l' ]. +C Workspace: ST*(N-ST)+2*N; +C + DO 30 J = BSN + 1, NC + CALL DCOPY( NTHS, R(1,J), 1, DWORK(L), ST ) + X(I) = R(I,J) + CALL DCOPY( NC-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + L = L + 1 + 30 CONTINUE +C + CALL DCOPY( N, QTB, 1, DWORK(IB), 1 ) + IF ( ST.GT.0 ) THEN + ITR = NTHS + 1 + ITC = BSN + 1 + ELSE + ITR = 1 + ITC = 1 + END IF + IBSN = 0 +C +C Eliminate the diagonal matrix D using Givens rotations. +C + DO 50 J = 1, N + IBSN = IBSN + 1 + I = IBSN +C +C Prepare the row of D to be eliminated, locating the +C diagonal element using P from the QR factorization. +C + L = IPVT(J) + IF ( DIAG(L).NE.ZERO ) THEN + QTBPJ = ZERO + DWORK(J) = DIAG(L) +C + DO 40 K = J + 1, MIN( J + KF - 1, N ) + DWORK(K) = ZERO + 40 CONTINUE +C +C The transformations to eliminate the row of D modify only +C a single element of Q'*b beyond the first n, which is +C initially zero. +C + IF ( J.LT.NTHS ) THEN + CALL MB04OW( BSN-IBSN+1, ST, 1, R(J,IBSN), LDR, + $ R(ITR,ITC), LDR, DWORK(J), 1, DWORK(IB+J-1), + $ BSN, DWORK(IB+NTHS), ST, QTBPJ, 1 ) + IF ( IBSN.EQ.BSN ) + $ IBSN = 0 + ELSE IF ( J.EQ.NTHS ) THEN + CALL MB04OW( 1, ST, 1, R(J,IBSN), LDR, R(ITR,ITC), LDR, + $ DWORK(J), 1, DWORK(IB+J-1), BSN, + $ DWORK(IB+NTHS), ST, QTBPJ, 1 ) + KF = ST + ELSE + CALL MB04OW( 0, N-J+1, 1, R(J,IBSN), LDR, R(J,IBSN), LDR, + $ DWORK(J), 1, DWORK(IB+J-1), 1, + $ DWORK(IB+J-1), ST, QTBPJ, 1 ) + END IF + ELSE + IF ( J.LT.NTHS ) THEN + IF ( IBSN.EQ.BSN ) + $ IBSN = 0 + ELSE IF ( J.EQ.NTHS ) THEN + KF = ST + END IF + END IF +C +C Store the diagonal element of S. +C + DWORK(J) = R(J,I) + 50 CONTINUE +C +C Solve the triangular system for z. If the system is singular, +C then obtain an approximate least squares solution. +C Additional workspace: 2*MAX(BSN,ST), if COND = 'E'; +C 0, if COND <> 'E'. +C + CALL NF01BR( COND, 'Upper', 'NoTranspose', N, IPAR, LIPAR, R, LDR, + $ DWORK, DWORK(IS), 1, DWORK(IB), RANKS, TOL, + $ DWORK(JW), LDWORK-JW+1, INFO ) + I = 1 +C +C Restore the diagonal elements of R from X and interchange +C the upper and lower triangular parts of R. +C + DO 70 K = 1, BN +C + DO 60 J = 1, BSN + R(I,J) = X(I) + CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 60 CONTINUE +C + 70 CONTINUE +C + DO 80 J = BSN + 1, NC + CALL DSWAP( NTHS, R(1,J), 1, DWORK(IS), ST ) + R(I,J) = X(I) + CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + IS = IS + 1 + 80 CONTINUE +C +C Permute the components of z back to components of x. +C + DO 90 J = 1, N + L = IPVT(J) + X(L) = DWORK(N+J) + 90 CONTINUE +C + RETURN +C +C *** Last line of NF01BQ *** + END diff --git a/mex/sources/libslicot/NF01BR.f b/mex/sources/libslicot/NF01BR.f new file mode 100644 index 000000000..4a68dab2b --- /dev/null +++ b/mex/sources/libslicot/NF01BR.f @@ -0,0 +1,711 @@ + SUBROUTINE NF01BR( COND, UPLO, TRANS, N, IPAR, LIPAR, R, LDR, + $ SDIAG, S, LDS, B, RANKS, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve one of the systems of linear equations +C +C R*x = b , or R'*x = b , +C +C in the least squares sense, where R is an n-by-n block upper +C triangular matrix, with the structure +C +C / R_1 0 .. 0 | L_1 \ +C | 0 R_2 .. 0 | L_2 | +C | : : .. : | : | , +C | 0 0 .. R_l | L_l | +C \ 0 0 .. 0 | R_l+1 / +C +C with the upper triangular submatrices R_k, k = 1:l+1, square, and +C the first l of the same order, BSN. The diagonal elements of each +C block R_k have nonincreasing magnitude. The matrix R is stored in +C the compressed form, as returned by SLICOT Library routine NF01BS, +C +C / R_1 | L_1 \ +C | R_2 | L_2 | +C Rc = | : | : | , +C | R_l | L_l | +C \ X | R_l+1 / +C +C where the submatrix X is irrelevant. If the matrix R does not have +C full rank, then a least squares solution is obtained. If l <= 1, +C then R is an upper triangular matrix and its full upper triangle +C is stored. +C +C Optionally, the transpose of the matrix R can be stored in the +C strict lower triangles of the submatrices R_k, k = 1:l+1, and in +C the arrays SDIAG and S, as described at the parameter UPLO below. +C +C ARGUMENTS +C +C Mode Parameters +C +C COND CHARACTER*1 +C Specifies whether the condition of submatrices R_k should +C be estimated, as follows: +C = 'E' : use incremental condition estimation and store +C the numerical rank of R_k in the array entry +C RANKS(k), for k = 1:l+1; +C = 'N' : do not use condition estimation, but check the +C diagonal entries of R_k for zero values; +C = 'U' : use the ranks already stored in RANKS(1:l+1). +C +C UPLO CHARACTER*1 +C Specifies the storage scheme for the matrix R, as follows: +C = 'U' : the upper triangular part is stored as in Rc; +C = 'L' : the lower triangular part is stored, namely, +C - the transpose of the strict upper triangle of +C R_k is stored in the strict lower triangle of +C R_k, for k = 1:l+1; +C - the diagonal elements of R_k, k = 1:l+1, are +C stored in the array SDIAG; +C - the transpose of the last block column in R +C (without R_l+1) is stored in the array S. +C +C TRANS CHARACTER*1 +C Specifies the form of the system of equations, as follows: +C = 'N': R*x = b (No transpose); +C = 'T': R'*x = b (Transpose); +C = 'C': R'*x = b (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix R. N = BN*BSN + ST >= 0. +C (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix R, as follows: +C IPAR(1) must contain ST, the number of columns of the +C submatrices L_k and the order of R_l+1. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, l, in the +C block diagonal part of R. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C R_k, k = 1:l. BSM >= 0. +C IPAR(4) must contain BSN, the number of columns of the +C blocks R_k, k = 1:l. BSN >= 0. +C BSM is not used by this routine, but assumed equal to BSN. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C R (input) DOUBLE PRECISION array, dimension (LDR, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C If UPLO = 'U', the leading N-by-NC part of this array must +C contain the (compressed) representation (Rc) of the upper +C triangular matrix R. The submatrix X in Rc and the strict +C lower triangular parts of the diagonal blocks R_k, +C k = 1:l+1, are not referenced. If BN <= 1 or BSN = 0, then +C the full upper triangle of R must be stored. +C If UPLO = 'L', BN > 1 and BSN > 0, the leading +C (N-ST)-by-BSN part of this array must contain the +C transposes of the strict upper triangles of R_k, k = 1:l, +C stored in the strict lower triangles of R_k, and the +C strict lower triangle of R_l+1 must contain the transpose +C of the strict upper triangle of R_l+1. The submatrix X +C in Rc is not referenced. The diagonal elements of R_k, +C and, if COND = 'E', the upper triangular parts of R_k, +C k = 1:l+1, are modified internally, but are restored +C on exit. +C If UPLO = 'L' and BN <= 1 or BSN = 0, the leading N-by-N +C strict lower triangular part of this array must contain +C the transpose of the strict upper triangular part of R. +C The diagonal elements and, if COND = 'E', the upper +C triangular elements are modified internally, but are +C restored on exit. +C +C LDR INTEGER +C The leading dimension of the array R. LDR >= MAX(1,N). +C +C SDIAG (input) DOUBLE PRECISION array, dimension (N) +C If UPLO = 'L', this array must contain the diagonal +C entries of R_k, k = 1:l+1. This array is modified +C internally, but is restored on exit. +C This parameter is not referenced if UPLO = 'U'. +C +C S (input) DOUBLE PRECISION array, dimension (LDS,N-ST) +C If UPLO = 'L', BN > 1, and BSN > 0, the leading +C ST-by-(N-ST) part of this array must contain the transpose +C of the rectangular part of the last block column in R, +C that is [ L_1' L_2' ... L_l' ] . If COND = 'E', S is +C modified internally, but is restored on exit. +C This parameter is not referenced if UPLO = 'U', or +C BN <= 1, or BSN = 0. +C +C LDS INTEGER +C The leading dimension of the array S. +C LDS >= 1, if UPLO = 'U', or BN <= 1, or BSN = 0; +C LDS >= MAX(1,ST), if UPLO = 'L', BN > 1, and BSN > 0. +C +C B (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the right hand side +C vector b. +C On exit, this array contains the (least squares) solution +C of the system R*x = b or R'*x = b. +C +C RANKS (input or output) INTEGER array, dimension (r), where +C r = BN + 1, if ST > 0, BSN > 0, and BN > 1; +C r = BN, if ST = 0 and BSN > 0; +C r = 1, if ST > 0 and ( BSN = 0 or BN <= 1 ); +C r = 0, if ST = 0 and BSN = 0. +C On entry, if COND = 'U' and N > 0, this array must contain +C the numerical ranks of the submatrices R_k, k = 1:l(+1). +C On exit, if COND = 'E' or 'N' and N > 0, this array +C contains the numerical ranks of the submatrices R_k, +C k = 1:l(+1), estimated according to the value of COND. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If COND = 'E', the tolerance to be used for finding the +C ranks of the submatrices R_k. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C the reciprocal condition number; a (sub)matrix whose +C estimated condition number is less than 1/TOL is +C considered to be of full rank. If the user sets TOL <= 0, +C then an implicitly computed, default tolerance, defined by +C TOLDEF = N*EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not relevant if COND = 'U' or 'N'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C Denote Full = ( BN <= 1 or BSN = 0 ); +C Comp = ( BN > 1 and BSN > 0 ). +C LDWORK >= 2*N, if Full and COND = 'E'; +C LDWORK >= 2*MAX(BSN,ST), if Comp and COND = 'E'; +C LDWORK >= 0, in the remaining cases. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Block back or forward substitution is used (depending on TRANS +C and UPLO), exploiting the special structure and storage scheme of +C the matrix R. If a submatrix R_k, k = 1:l+1, is singular, a local +C basic least squares solution is computed. Therefore, the returned +C result is not the basic least squares solution for the whole +C problem, but a concatenation of (least squares) solutions of the +C individual subproblems involving R_k, k = 1:l+1 (with adapted +C right hand sides). +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires 0(BN*BSN + ST + N*ST) operations and is +C backward stable, if R is nonsingular. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Linear system of equations, matrix operations, plane rotations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, SVLMAX + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, SVLMAX = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COND, TRANS, UPLO + INTEGER INFO, LDR, LDS, LDWORK, LIPAR, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IPAR(*), RANKS(*) + DOUBLE PRECISION B(*), DWORK(*), R(LDR,*), S(LDS,*), SDIAG(*) +C .. Local Scalars .. + DOUBLE PRECISION TOLDEF + INTEGER BN, BSM, BSN, I, I1, J, K, L, NC, NTHS, RANK, ST + CHARACTER TRANSL, UPLOL + LOGICAL ECOND, FULL, LOWER, NCOND, TRANR +C .. Local Arrays .. + DOUBLE PRECISION DUM(3) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DSWAP, DTRSV, MB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + ECOND = LSAME( COND, 'E' ) + NCOND = LSAME( COND, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + TRANR = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) +C + INFO = 0 + IF( .NOT.( ECOND .OR. NCOND .OR. LSAME( COND, 'U' ) ) ) THEN + INFO = -1 + ELSEIF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSEIF( .NOT.( TRANR .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -3 + ELSEIF( N.LT.0 ) THEN + INFO = -4 + ELSEIF( LIPAR.LT.4 ) THEN + INFO = -6 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + FULL = BN.LE.1 .OR. BSN.EQ.0 + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -5 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -4 + ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDS.LT.1 .OR. ( LOWER .AND. .NOT.FULL .AND. + $ LDS.LT.ST ) ) THEN + INFO = -11 + ELSE + IF ( ECOND ) THEN + IF ( FULL ) THEN + L = 2*N + ELSE + L = 2*MAX( BSN, ST ) + END IF + ELSE + L = 0 + END IF + IF ( LDWORK.LT.L ) + $ INFO = -16 + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BR', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + IF ( ECOND ) THEN + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in rank determination. +C + TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' ) + END IF + END IF +C + NC = BSN + ST + IF ( FULL ) THEN +C +C Special case: l <= 1 or BSN = 0; R is just an upper triangular +C matrix. +C + IF ( LOWER ) THEN +C +C Swap the diagonal elements of R and the elements of SDIAG +C and, if COND = 'E', swap the upper and lower triangular +C parts of R, in order to find the numerical rank. +C + CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) + IF ( ECOND ) THEN + UPLOL = 'U' + TRANSL = TRANS +C + DO 10 J = 1, N + CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) + 10 CONTINUE +C + ELSE + UPLOL = UPLO + IF ( TRANR ) THEN + TRANSL = 'N' + ELSE + TRANSL = 'T' + END IF + END IF + ELSE + UPLOL = UPLO + TRANSL = TRANS + END IF +C + IF ( ECOND ) THEN +C +C Estimate the reciprocal condition number and set the rank. +C Workspace: 2*N. +C + CALL MB03OD( 'No QR', N, N, R, LDR, IPAR, TOLDEF, SVLMAX, + $ DWORK, RANK, DUM, DWORK, LDWORK, INFO ) + RANKS(1) = RANK +C + ELSEIF ( NCOND ) THEN +C +C Determine rank(R) by checking zero diagonal entries. +C + RANK = N +C + DO 20 J = 1, N + IF ( R(J,J).EQ.ZERO .AND. RANK.EQ.N ) + $ RANK = J - 1 + 20 CONTINUE +C + RANKS(1) = RANK +C + ELSE +C +C Use the stored rank. +C + RANK = RANKS(1) + END IF +C +C Solve R*x = b, or R'*x = b using back or forward substitution. +C + DUM(1) = ZERO + IF ( RANK.LT.N ) + $ CALL DCOPY( N-RANK, DUM, 0, B(RANK+1), 1 ) + CALL DTRSV( UPLOL, TRANSL, 'NonUnit', RANK, R, LDR, B, 1 ) +C + IF ( LOWER ) THEN +C +C Swap the diagonal elements of R and the elements of SDIAG +C and, if COND = 'E', swap back the upper and lower triangular +C parts of R. +C + CALL DSWAP( N, R, LDR+1, SDIAG, 1 ) + IF ( ECOND ) THEN +C + DO 30 J = 1, N + CALL DSWAP( N-J+1, R(J,J), LDR, R(J,J), 1 ) + 30 CONTINUE +C + END IF +C + END IF + RETURN + END IF +C +C General case: l > 1 and BSN > 0. +C + I = 1 + L = BN + IF ( ECOND ) THEN +C +C Estimate the reciprocal condition numbers and set the ranks. +C + IF ( LOWER ) THEN +C +C Swap the diagonal elements of R and the elements of SDIAG +C and swap the upper and lower triangular parts of R, in order +C to find the numerical rank. Swap S and the transpose of the +C rectangular part of the last block column of R. +C + DO 50 K = 1, BN + CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) +C + DO 40 J = 1, BSN + CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 40 CONTINUE +C + 50 CONTINUE +C + IF ( ST.GT.0 ) THEN + CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) +C + DO 60 J = BSN + 1, NC + CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) + CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 60 CONTINUE +C + END IF +C + END IF +C + I1 = 1 +C +C Determine rank(R_k) using incremental condition estimation. +C Workspace 2*MAX(BSN,ST). +C + DO 70 K = 1, BN + CALL MB03OD( 'No QR', BSN, BSN, R(I1,1), LDR, IPAR, TOLDEF, + $ SVLMAX, DWORK, RANKS(K), DUM, DWORK, LDWORK, + $ INFO ) + I1 = I1 + BSN + 70 CONTINUE +C + IF ( ST.GT.0 ) THEN + L = L + 1 + CALL MB03OD( 'No QR', ST, ST, R(I1,BSN+1), LDR, IPAR, + $ TOLDEF, SVLMAX, DWORK, RANKS(L), DUM, DWORK, + $ LDWORK, INFO ) + END IF +C + ELSEIF ( NCOND ) THEN +C +C Determine rank(R_k) by checking zero diagonal entries. +C + IF ( LOWER ) THEN +C + DO 90 K = 1, BN + RANK = BSN +C + DO 80 J = 1, BSN + IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.BSN ) + $ RANK = J - 1 + I = I + 1 + 80 CONTINUE +C + RANKS(K) = RANK + 90 CONTINUE +C + IF ( ST.GT.0 ) THEN + L = L + 1 + RANK = ST +C + DO 100 J = 1, ST + IF ( SDIAG(I).EQ.ZERO .AND. RANK.EQ.ST ) + $ RANK = J - 1 + I = I + 1 + 100 CONTINUE +C + RANKS(L) = RANK + END IF +C + ELSE +C + DO 120 K = 1, BN + RANK = BSN +C + DO 110 J = 1, BSN + IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.BSN ) + $ RANK = J - 1 + I = I + 1 + 110 CONTINUE +C + RANKS(K) = RANK + 120 CONTINUE +C + IF ( ST.GT.0 ) THEN + L = L + 1 + RANK = ST +C + DO 130 J = BSN + 1, NC + IF ( R(I,J).EQ.ZERO .AND. RANK.EQ.ST ) + $ RANK = J - BSN - 1 + I = I + 1 + 130 CONTINUE +C + RANKS(L) = RANK + END IF + END IF +C + ELSE +C +C Set the number of elements of RANKS. Then use the stored ranks. +C + IF ( ST.GT.0 ) + $ L = L + 1 + END IF +C +C Solve the triangular system for x. If the system is singular, +C then obtain a basic least squares solution. +C + DUM(1) = ZERO + IF ( LOWER .AND. .NOT.ECOND ) THEN +C + IF ( .NOT.TRANR ) THEN +C +C Solve R*x = b using back substitution, with R' stored in +C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. +C + I1 = NTHS + 1 + IF ( ST.GT.0 ) THEN + RANK = RANKS(L) + IF ( RANK.LT.ST ) + $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) + CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, + $ R(I1,BSN+1), LDR, B(I1), 1 ) + CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) + CALL DGEMV( 'Transpose', ST, NTHS, -ONE, S, LDS, + $ B(NTHS+1), 1, ONE, B, 1 ) + END IF +C + DO 140 K = BN, 1, -1 + I1 = I1 - BSN + RANK = RANKS(K) + IF ( RANK.LT.BSN ) + $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) + CALL DTRSV( 'Lower', 'Transpose', 'NonUnit', RANK, + $ R(I1,1), LDR, B(I1), 1 ) + CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) + 140 CONTINUE +C + ELSE +C +C Solve R'*x = b using forward substitution, with R' stored in +C the arrays R, SDIAG and S. Swap diag(R) and SDIAG. +C + I1 = 1 + IF ( TRANR ) THEN + TRANSL = 'N' + ELSE + TRANSL = 'T' + END IF +C + DO 150 K = 1, BN + RANK = RANKS(K) + IF ( RANK.LT.BSN ) + $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) + CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, R(I1,1), + $ LDR, B(I1), 1 ) + CALL DSWAP( BSN, R(I1,1), LDR+1, SDIAG(I1), 1 ) + I1 = I1 + BSN + 150 CONTINUE +C + IF ( ST.GT.0 ) THEN + RANK = RANKS(L) + IF ( RANK.LT.ST ) + $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DGEMV( 'NoTranspose', ST, NTHS, -ONE, S, LDS, B, 1, + $ ONE, B(I1), 1 ) + CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) + CALL DTRSV( 'Lower', TRANSL, 'NonUnit', RANK, + $ R(I1,BSN+1), LDR, B(I1), 1 ) + CALL DSWAP( ST, R(I1,BSN+1), LDR+1, SDIAG(I1), 1 ) + END IF +C + END IF +C + ELSE +C + IF ( .NOT.TRANR ) THEN +C +C Solve R*x = b using back substitution. +C + I1 = NTHS + 1 + IF ( ST.GT.0 ) THEN + RANK = RANKS(L) + IF ( RANK.LT.ST ) + $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), + $ LDR, B(I1), 1 ) + CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, + $ B(NTHS+1), 1, ONE, B, 1 ) + END IF +C + DO 160 K = BN, 1, -1 + I1 = I1 - BSN + RANK = RANKS(K) + IF ( RANK.LT.BSN ) + $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), + $ LDR, B(I1), 1 ) + 160 CONTINUE +C + ELSE +C +C Solve R'*x = b using forward substitution. +C + I1 = 1 +C + DO 170 K = 1, BN + RANK = RANKS(K) + IF ( RANK.LT.BSN ) + $ CALL DCOPY( BSN-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,1), + $ LDR, B(I1), 1 ) + I1 = I1 + BSN + 170 CONTINUE +C + IF ( ST.GT.0 ) THEN + RANK = RANKS(L) + IF ( RANK.LT.ST ) + $ CALL DCOPY( ST-RANK, DUM, 0, B(I1+RANK), 1 ) + CALL DGEMV( TRANS, NTHS, ST, -ONE, R(1,BSN+1), LDR, B, 1, + $ ONE, B(I1), 1 ) + CALL DTRSV( 'Upper', TRANS, 'NonUnit', RANK, R(I1,BSN+1), + $ LDR, B(I1), 1 ) + END IF +C + END IF + END IF +C + IF ( ECOND .AND. LOWER ) THEN + I = 1 +C +C If COND = 'E' and UPLO = 'L', swap the diagonal elements of R +C and the elements of SDIAG and swap back the upper and lower +C triangular parts of R, including the part corresponding to S. +C + DO 190 K = 1, BN + CALL DSWAP( BSN, R(I,1), LDR+1, SDIAG(I), 1 ) +C + DO 180 J = 1, BSN + CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 180 CONTINUE +C + 190 CONTINUE +C + IF ( ST.GT.0 ) THEN + CALL DSWAP( ST, R(I,BSN+1), LDR+1, SDIAG(I), 1 ) +C + DO 200 J = BSN + 1, NC + CALL DSWAP( NTHS, R(1,J), 1, S(J-BSN,1), LDS ) + CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 ) + I = I + 1 + 200 CONTINUE +C + END IF +C + END IF +C + RETURN +C +C *** Last line of NF01BR *** + END diff --git a/mex/sources/libslicot/NF01BS.f b/mex/sources/libslicot/NF01BS.f new file mode 100644 index 000000000..3d7d6e5c9 --- /dev/null +++ b/mex/sources/libslicot/NF01BS.f @@ -0,0 +1,610 @@ + SUBROUTINE NF01BS( N, IPAR, LIPAR, FNORM, J, LDJ, E, JNORMS, + $ GNORM, IPVT, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the QR factorization of the Jacobian matrix J, as +C received in compressed form from SLICOT Library routine NF01BD, +C +C / dy(1)/dwb(1) | dy(1)/ dtheta \ +C Jc = | : | : | , +C \ dy(L)/dwb(L) | dy(L)/ dtheta / +C +C and to apply the transformation Q on the error vector e (in-situ). +C The factorization is J*P = Q*R, where Q is a matrix with +C orthogonal columns, P a permutation matrix, and R an upper +C trapezoidal matrix with diagonal elements of nonincreasing +C magnitude for each block column (see below). The 1-norm of the +C scaled gradient is also returned. +C +C Actually, the Jacobian J has the block form +C +C dy(1)/dwb(1) 0 ..... 0 dy(1)/dtheta +C 0 dy(2)/dwb(2) ..... 0 dy(2)/dtheta +C ..... ..... ..... ..... ..... +C 0 ..... 0 dy(L)/dwb(L) dy(L)/dtheta +C +C but the zero blocks are omitted. The diagonal blocks have the +C same size and correspond to the nonlinear part. The last block +C column corresponds to the linear part. It is assumed that the +C Jacobian matrix has at least as many rows as columns. The linear +C or nonlinear parts can be empty. If L <= 1, the Jacobian is +C represented as a full matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. +C N = BN*BSN + ST >= 0. (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain ST, the number of parameters +C corresponding to the linear part. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, BN = L, +C for the parameters corresponding to the nonlinear +C part. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the +C number of rows of the matrix J, if BN <= 1. +C BN*BSM >= N, if BN > 0; +C BSM >= N, if BN = 0. +C IPAR(4) must contain BSN, the number of columns of the +C blocks J_k, k = 1:BN. BSN >= 0. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C FNORM (input) DOUBLE PRECISION +C The Euclidean norm of the vector e. FNORM >= 0. +C +C J (input/output) DOUBLE PRECISION array, dimension (LDJ, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C On entry, the leading NR-by-NC part of this array must +C contain the (compressed) representation (Jc) of the +C Jacobian matrix J, where NR = BSM if BN <= 1, and +C NR = BN*BSM, if BN > 1. +C On exit, the leading N-by-NC part of this array contains +C a (compressed) representation of the upper triangular +C factor R of the Jacobian matrix. The matrix R has the same +C structure as the Jacobian matrix J, but with an additional +C diagonal block. Note that for efficiency of the later +C calculations, the matrix R is delivered with the leading +C dimension MAX(1,N), possibly much smaller than the value +C of LDJ on entry. +C +C LDJ (input/output) INTEGER +C The leading dimension of array J. +C On entry, LDJ >= MAX(1,NR). +C On exit, LDJ >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (NR) +C On entry, this array contains the vector e, +C e = vec( Y - y ), where Y is set of output samples, and +C vec denotes the concatenation of the columns of a matrix. +C On exit, this array contains the updated vector Z*Q'*e, +C where Z is the block row permutation matrix used in the +C QR factorization of J (see METHOD). +C +C JNORMS (output) DOUBLE PRECISION array, dimension (N) +C This array contains the Euclidean norms of the columns +C of the Jacobian matrix, considered in the initial order. +C +C GNORM (output) DOUBLE PRECISION +C If FNORM > 0, the 1-norm of the scaled vector J'*e/FNORM, +C with each element i further divided by JNORMS(i) (if +C JNORMS(i) is nonzero). +C If FNORM = 0, the returned value of GNORM is 0. +C +C IPVT (output) INTEGER array, dimension (N) +C This array defines the permutation matrix P such that +C J*P = Q*R. Column j of P is column IPVT(j) of the identity +C matrix. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1, if N = 0 or BN <= 1 and BSM = N = 1; +C otherwise, +C LDWORK >= 4*N+1, if BN <= 1 or BSN = 0; +C LDWORK >= JWORK, if BN > 1 and BSN > 0, where JWORK is +C given by the following procedure: +C JWORK = BSN + MAX(3*BSN+1,ST); +C JWORK = MAX(JWORK,4*ST+1), if BSM > BSN; +C JWORK = MAX(JWORK,(BSM-BSN)*(BN-1)), +C if BSN < BSM < 2*BSN. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C A QR factorization with column pivoting of the matrix J is +C computed, J*P = Q*R. +C +C If l = L > 1, the R factor of the QR factorization has the same +C structure as the Jacobian, but with an additional diagonal block. +C Denote +C +C / J_1 0 .. 0 | L_1 \ +C | 0 J_2 .. 0 | L_2 | +C J = | : : .. : | : | . +C | : : .. : | : | +C \ 0 0 .. J_l | L_l / +C +C The algorithm consists in two phases. In the first phase, the +C algorithm uses QR factorizations with column pivoting for each +C block J_k, k = 1:l, and applies the orthogonal matrix Q'_k to the +C corresponding part of the last block column and of e. After all +C block rows have been processed, the block rows are interchanged +C so that the zeroed submatrices in the first l block columns are +C moved to the bottom part. The same block row permutation Z is +C also applied to the vector e. At the end of the first phase, +C the structure of the processed matrix J is +C +C / R_1 0 .. 0 | L^1_1 \ +C | 0 R_2 .. 0 | L^1_2 | +C | : : .. : | : | . +C | : : .. : | : | +C | 0 0 .. R_l | L^1_l | +C | 0 0 .. 0 | L^2_1 | +C | : : .. : | : | +C \ 0 0 .. 0 | L^2_l / +C +C In the second phase, the submatrix L^2_1:l is triangularized +C using an additional QR factorization with pivoting. (The columns +C of L^1_1:l are also permuted accordingly.) Therefore, the column +C pivoting is restricted to each such local block column. +C +C If l <= 1, the matrix J is triangularized in one phase, by one +C QR factorization with pivoting. In this case, the column +C pivoting is global. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001. +C +C REVISIONS +C +C Feb. 22, 2004. +C +C KEYWORDS +C +C Elementary matrix operations, Jacobian matrix, matrix algebra, +C matrix operations, Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDJ, LDWORK, LIPAR, N + DOUBLE PRECISION FNORM, GNORM +C .. Array Arguments .. + INTEGER IPAR(*), IPVT(*) + DOUBLE PRECISION DWORK(*), E(*), J(*), JNORMS(*) +C .. Local Scalars .. + INTEGER BN, BSM, BSN, I, IBSM, IBSN, IBSNI, ITAU, JL, + $ JLM, JWORK, K, L, M, MMN, NTHS, ST, WRKOPT + DOUBLE PRECISION SUM +C .. External Functions .. + DOUBLE PRECISION DDOT, DNRM2 + EXTERNAL DDOT, DNRM2 +C .. External Subroutines .. + EXTERNAL DCOPY, DGEQP3, DLACPY, DLAPMT, DORMQR, DSWAP, + $ MD03BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSEIF( LIPAR.LT.4 ) THEN + INFO = -3 + ELSEIF ( FNORM.LT.ZERO ) THEN + INFO = -4 + ELSEIF ( LDJ.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + MMN = BSM - BSN + IF ( BN.GT.0 ) THEN + M = BN*BSM + ELSE + M = N + END IF + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -2 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -1 + ELSEIF ( M.LT.N ) THEN + INFO = -2 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE + IF ( N.EQ.0 ) THEN + JWORK = 1 + ELSEIF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN + IF ( BN.LE.1 .AND. BSM.EQ.1 .AND. N.EQ.1 ) THEN + JWORK = 1 + ELSE + JWORK = 4*N + 1 + END IF + ELSE + JWORK = BSN + MAX( 3*BSN + 1, ST ) + IF ( BSM.GT.BSN ) THEN + JWORK = MAX( JWORK, 4*ST + 1 ) + IF ( BSM.LT.2*BSN ) + $ JWORK = MAX( JWORK, MMN*( BN - 1 ) ) + END IF + END IF + IF ( LDWORK.LT.JWORK ) + $ INFO = -12 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'NF01BS', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + GNORM = ZERO + IF ( N.EQ.0 ) THEN + LDJ = 1 + DWORK(1) = ONE + RETURN + END IF +C + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN +C +C Special case, l <= 1 or BSN = 0: the Jacobian is represented +C as a full matrix. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C Workspace: need: 4*N + 1; +C prefer: 3*N + ( N+1 )*NB. +C + CALL MD03BX( M, N, FNORM, J, LDJ, E, JNORMS, GNORM, IPVT, + $ DWORK, LDWORK, INFO ) + RETURN + END IF +C +C General case: l > 1 and BSN > 0. +C Initialize the column pivoting indices. +C + DO 10 I = 1, N + IPVT(I) = 0 + 10 CONTINUE +C +C Compute the QR factorization with pivoting of J. +C Pivoting is done separately on each block column of J. +C + WRKOPT = 1 + IBSN = 1 + JL = LDJ*BSN + 1 + JWORK = BSN + 1 +C + DO 30 IBSM = 1, M, BSM +C +C Compute the QR factorization with pivoting of J_k, and apply Q' +C to the corresponding part of the last block-column and of e. +C Workspace: need: 4*BSN + 1; +C prefer: 3*BSN + ( BSN+1 )*NB. +C + CALL DGEQP3( BSM, BSN, J(IBSM), LDJ, IPVT(IBSN), DWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + IF ( IBSM.GT.1 ) THEN +C +C Adjust the column pivoting indices. +C + DO 20 I = IBSN, IBSN + BSN - 1 + IPVT(I) = IPVT(I) + IBSN - 1 + 20 CONTINUE +C + END IF +C + IF ( ST.GT.0 ) THEN +C +C Workspace: need: BSN + ST; +C prefer: BSN + ST*NB. +C + CALL DORMQR( 'Left', 'Transpose', BSM, ST, BSN, J(IBSM), + $ LDJ, DWORK, J(JL), LDJ, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + END IF +C +C Workspace: need: BSN + 1; +C prefer: BSN + NB. +C + CALL DORMQR( 'Left', 'Transpose', BSM, 1, BSN, J(IBSM), LDJ, + $ DWORK, E(IBSM), BSM, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + JL = JL + BSM + IBSN = IBSN + BSN + 30 CONTINUE +C + IF ( MMN.GT.0 ) THEN +C +C Case BSM > BSN. +C Compute the original column norms for the first block column +C of Jc. +C Permute the rows of the first block column to move the zeroed +C submatrices to the bottom. In the same loops, reshape the +C first block column of R to have the leading dimension N. +C + L = IPVT(1) + JNORMS(L) = ABS( J(1) ) + IBSM = BSM + 1 + IBSN = BSN + 1 +C + DO 40 K = 1, BN - 1 + J(IBSN) = J(IBSM) + L = IPVT(IBSN) + JNORMS(L) = ABS( J(IBSN) ) + IBSM = IBSM + BSM + IBSN = IBSN + BSN + 40 CONTINUE +C + IBSN = IBSN + ST +C + DO 60 I = 2, BSN + IBSM = ( I - 1 )*LDJ + 1 + JL = I +C + DO 50 K = 1, BN +C + DO 45 L = 0, I - 1 + J(IBSN+L) = J(IBSM+L) + 45 CONTINUE +C + L = IPVT(JL) + JNORMS(L) = DNRM2( I, J(IBSN), 1 ) + IBSM = IBSM + BSM + IBSN = IBSN + BSN + JL = JL + BSN + 50 CONTINUE +C + IBSN = IBSN + ST + 60 CONTINUE +C +C Permute the rows of the second block column of Jc and of +C the vector e. +C + JL = LDJ*BSN + IF ( BSM.GE.2*BSN ) THEN +C +C A swap operation can be used. +C + DO 80 I = 1, ST + IBSN = BSN + 1 +C + DO 70 IBSM = BSM + 1, M, BSM + CALL DSWAP( MMN, J(JL+IBSM), 1, J(JL+IBSN), 1 ) + IBSN = IBSN + BSN + 70 CONTINUE +C + JL = JL + LDJ + 80 CONTINUE +C +C Permute the rows of e. +C + IBSN = BSN + 1 +C + DO 90 IBSM = BSM + 1, M, BSM + CALL DSWAP( MMN, E(IBSM), 1, E(IBSN), 1 ) + IBSN = IBSN + BSN + 90 CONTINUE +C + ELSE +C +C A swap operation cannot be used. +C Workspace: need: ( BSM-BSN )*( BN-1 ). +C + DO 110 I = 1, ST + IBSN = BSN + 1 + JLM = JL + IBSN + JWORK = 1 +C + DO 100 IBSM = BSM + 1, M, BSM + CALL DCOPY( MMN, J(JLM), 1, DWORK(JWORK), 1 ) +C + DO 105 K = JL, JL + BSN - 1 + J(IBSN+K) = J(IBSM+K) + 105 CONTINUE +C + JLM = JLM + BSM + IBSN = IBSN + BSN + JWORK = JWORK + MMN + 100 CONTINUE +C + CALL DCOPY( MMN*( BN-1 ), DWORK, 1, J(JL+IBSN), 1 ) + JL = JL + LDJ + 110 CONTINUE +C +C Permute the rows of e. +C + IBSN = BSN + 1 + JLM = IBSN + JWORK = 1 +C + DO 120 IBSM = BSM + 1, M, BSM + CALL DCOPY( MMN, E(JLM), 1, DWORK(JWORK), 1 ) +C + DO 115 K = 0, BSN - 1 + E(IBSN+K) = E(IBSM+K) + 115 CONTINUE +C + JLM = JLM + BSM + IBSN = IBSN + BSN + JWORK = JWORK + MMN + 120 CONTINUE +C + CALL DCOPY( MMN*( BN-1 ), DWORK, 1, E(IBSN), 1 ) + END IF +C + IF ( ST.GT.0 ) THEN +C +C Compute the QR factorization with pivoting of the submatrix +C L^2_1:l, and apply Q' to the corresponding part of e. +C +C Workspace: need: 4*ST + 1; +C prefer: 3*ST + ( ST+1 )*NB. +C + JL = ( LDJ + BN )*BSN + 1 + ITAU = 1 + JWORK = ITAU + ST + CALL DGEQP3( MMN*BN, ST, J(JL), LDJ, IPVT(NTHS+1), + $ DWORK(ITAU), DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Permute columns of the upper part of the second block +C column of Jc. +C + CALL DLAPMT( .TRUE., NTHS, ST, J(JL-NTHS), LDJ, + $ IPVT(NTHS+1) ) +C +C Adjust the column pivoting indices. +C + DO 130 I = NTHS + 1, N + IPVT(I) = IPVT(I) + NTHS + 130 CONTINUE +C +C Workspace: need: ST + 1; +C prefer: ST + NB. +C + CALL DORMQR( 'Left', 'Transpose', MMN*BN, 1, ST, J(JL), LDJ, + $ DWORK(ITAU), E(IBSN), LDJ, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Reshape the second block column of R to have the leading +C dimension N. +C + IBSN = N*BSN + 1 + CALL DLACPY( 'Full', N, ST, J(LDJ*BSN+1), LDJ, J(IBSN), N ) +C +C Compute the original column norms for the second block +C column. +C + DO 140 I = NTHS + 1, N + L = IPVT(I) + JNORMS(L) = DNRM2( I, J(IBSN), 1 ) + IBSN = IBSN + N + 140 CONTINUE +C + END IF +C + ELSE +C +C Case BSM = BSN. +C Compute the original column norms for the first block column +C of Jc. +C + IBSN = 1 +C + DO 160 I = 1, BSN + JL = I +C + DO 150 K = 1, BN + L = IPVT(JL) + JNORMS(L) = DNRM2( I, J(IBSN), 1 ) + IBSN = IBSN + BSN + JL = JL + BSN + 150 CONTINUE +C + IBSN = IBSN + ST + 160 CONTINUE +C + DO 170 I = NTHS + 1, N + IPVT(I) = I + 170 CONTINUE +C + END IF +C +C Compute the norm of the scaled gradient. +C + IF ( FNORM.NE.ZERO ) THEN +C + DO 190 IBSN = 1, NTHS, BSN + IBSNI = IBSN +C + DO 180 I = 1, BSN + L = IPVT(IBSN+I-1) + IF ( JNORMS(L).NE.ZERO ) THEN + SUM = DDOT( I, J(IBSNI), 1, E(IBSN), 1 )/FNORM + GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) + END IF + IBSNI = IBSNI + N + 180 CONTINUE +C + 190 CONTINUE +C + IBSNI = N*BSN + 1 +C + DO 200 I = NTHS + 1, N + L = IPVT(I) + IF ( JNORMS(L).NE.ZERO ) THEN + SUM = DDOT( I, J(IBSNI), 1, E, 1 )/FNORM + GNORM = MAX( GNORM, ABS( SUM/JNORMS(L) ) ) + END IF + IBSNI = IBSNI + N + 200 CONTINUE +C + END IF +C + LDJ = N + DWORK(1) = WRKOPT + RETURN +C +C *** Last line of NF01BS *** + END diff --git a/mex/sources/libslicot/NF01BU.f b/mex/sources/libslicot/NF01BU.f new file mode 100644 index 000000000..502959cdd --- /dev/null +++ b/mex/sources/libslicot/NF01BU.f @@ -0,0 +1,398 @@ + SUBROUTINE NF01BU( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, + $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix J'*J + c*I, for the Jacobian J as received +C from SLICOT Library routine NF01BD: +C +C / dy(1)/dwb(1) | dy(1)/dtheta \ +C Jc = | : | : | . +C \ dy(L)/dwb(L) | dy(L)/dtheta / +C +C This is a compressed representation of the actual structure +C +C / J_1 0 .. 0 | L_1 \ +C | 0 J_2 .. 0 | L_2 | +C J = | : : .. : | : | . +C | : : .. : | : | +C \ 0 0 .. J_L | L_L / +C +C ARGUMENTS +C +C Mode Parameters +C +C STOR CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix J'*J + c*I, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix J'*J + c*I is stored, +C as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix J'*J + c*I. +C N = BN*BSN + ST >= 0. (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain ST, the number of parameters +C corresponding to the linear part. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, BN = L, +C for the parameters corresponding to the nonlinear +C part. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the +C number of rows of the matrix J, if BN <= 1. +C IPAR(4) must contain BSN, the number of columns of the +C blocks J_k, k = 1:BN. BSN >= 0. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the problem. +C The entry DPAR(1) must contain the real scalar c. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C The leading NR-by-NC part of this array must contain +C the (compressed) representation (Jc) of the Jacobian +C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, +C if BN > 1. +C +C LDJ (input) INTEGER +C The leading dimension of array J. LDJ >= MAX(1,NR). +C +C JTJ (output) DOUBLE PRECISION array, +C dimension (LDJTJ,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if +C STOR = 'P') part of this array contains the upper or +C lower triangle of the matrix J'*J + c*I, depending on +C UPLO = 'U', or UPLO = 'L', respectively, stored either as +C a two-dimensional, or one-dimensional array, depending +C on STOR. +C +C LDJTJ INTEGER +C The leading dimension of the array JTJ. +C LDJTJ >= MAX(1,N), if STOR = 'F'. +C LDJTJ >= 1, if STOR = 'P'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C Currently, this array is not used. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix product is computed columnn-wise, exploiting the +C symmetry. BLAS 3 routines DGEMM and DSYRK are used if STOR = 'F', +C and BLAS 2 routine DGEMV is used if STOR = 'P'. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. +C +C REVISIONS +C +C V. Sima, Dec. 2001, Mar. 2002. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations, +C Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER STOR, UPLO + INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N +C .. Array Arguments .. + DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) + INTEGER IPAR(*) +C .. Local Scalars .. + LOGICAL FULL, UPPER + INTEGER BN, BSM, BSN, I1, IBSM, IBSN, II, JL, K, M, + $ NBSN, NTHS, ST + DOUBLE PRECISION C +C .. Local Arrays .. + DOUBLE PRECISION TMP(1) + INTEGER ITMP(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DSYRK, NF01BV, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 +C + FULL = LSAME( STOR, 'F' ) + UPPER = LSAME( UPLO, 'U' ) +C + IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSEIF ( N.LT.0 ) THEN + INFO = -3 + ELSEIF ( LIPAR.LT.4 ) THEN + INFO = -5 + ELSEIF ( LDPAR.LT.1 ) THEN + INFO = -7 + ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN + INFO = -11 + ELSEIF ( LDWORK.LT.0 ) THEN + INFO = -13 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + IF ( BN.GT.1 ) THEN + M = BN*BSM + ELSE + M = BSM + END IF + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -4 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -3 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BU', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + C = DPAR(1) +C + IF ( BN.LE.1 .OR. BSN.EQ.0 .OR. BSM.EQ.0 ) THEN +C +C Special case, l <= 1 or BSN = 0 or BSM = 0: the Jacobian is +C represented as a full matrix. +C + ITMP(1) = M + CALL NF01BV( STOR, UPLO, N, ITMP, 1, DPAR, 1, J, LDJ, JTJ, + $ LDJTJ, DWORK, LDWORK, INFO ) + RETURN + END IF +C +C General case: l > 1, BSN > 0, BSM > 0. +C + JL = BSN + 1 +C + IF ( FULL ) THEN +C + NBSN = N*BSN +C + IF ( UPPER ) THEN +C +C Compute the leading upper triangular part (full storage). +C + CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ, LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J, LDJ, ONE, + $ JTJ, LDJTJ ) + IBSN = BSN + I1 = NBSN + 1 +C + DO 10 IBSM = BSM + 1, M, BSM + II = I1 + IBSN + CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), + $ LDJTJ ) + I1 = I1 + NBSN + CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), + $ LDJ, ONE, JTJ(II), LDJTJ ) + IBSN = IBSN + BSN + 10 CONTINUE +C + IF ( ST.GT.0 ) THEN +C +C Compute the last block column. +C + DO 20 IBSM = 1, M, BSM + CALL DGEMM( 'Transpose', 'NoTranspose', BSN, ST, BSM, + $ ONE, J(IBSM,1), LDJ, J(IBSM,JL), LDJ, + $ ZERO, JTJ(I1), LDJTJ ) + I1 = I1 + BSN + 20 CONTINUE +C + CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(I1), LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), + $ LDJ, ONE, JTJ(I1), LDJTJ ) + END IF +C + ELSE +C +C Compute the leading lower triangular part (full storage). +C + IBSN = NTHS + II = 1 +C + DO 30 IBSM = 1, M, BSM + I1 = II + BSN + CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1), + $ LDJ, ONE, JTJ(II), LDJTJ ) + IBSN = IBSN - BSN + CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1), + $ LDJTJ ) + II = I1 + NBSN + IF ( ST.GT.0 ) + $ CALL DGEMM( 'Transpose', 'NoTranspose', ST, BSN, BSM, + $ ONE, J(IBSM,JL), LDJ, J(IBSM,1), LDJ, + $ ZERO, JTJ(I1+IBSN), LDJTJ ) + 30 CONTINUE +C + IF ( ST.GT.0 ) THEN +C +C Compute the last diagonal block. +C + CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(II), LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', ST, M, ONE, J(1,JL), + $ LDJ, ONE, JTJ(II), LDJTJ ) + END IF +C + END IF +C + ELSE +C + TMP(1) = ZERO +C + IF ( UPPER ) THEN +C +C Compute the leading upper triangular part (packed storage). +C + IBSN = 0 + I1 = 1 +C + DO 50 IBSM = 1, M, BSM +C + DO 40 K = 1, BSN + II = I1 + IBSN + CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) + CALL DGEMV( 'Transpose', BSM, K, ONE, J(IBSM,1), LDJ, + $ J(IBSM,K), 1, ZERO, JTJ(II), 1 ) + I1 = II + K + JTJ(I1-1) = JTJ(I1-1) + C + 40 CONTINUE +C + IBSN = IBSN + BSN + 50 CONTINUE +C +C Compute the last block column. +C + DO 70 K = 1, ST +C + DO 60 IBSM = 1, M, BSM + CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), + $ LDJ, J(IBSM,BSN+K), 1, ZERO, JTJ(I1), 1 ) + I1 = I1 + BSN + 60 CONTINUE +C + CALL DGEMV( 'Transpose', M, K, ONE, J(1,JL), LDJ, + $ J(1,BSN+K), 1, ZERO, JTJ(I1), 1 ) + I1 = I1 + K + JTJ(I1-1) = JTJ(I1-1) + C + 70 CONTINUE +C + ELSE +C +C Compute the leading lower triangular part (packed storage). +C + IBSN = NTHS + II = 1 +C + DO 90 IBSM = 1, M, BSM + IBSN = IBSN - BSN +C + DO 80 K = 1, BSN + I1 = II + BSN - K + 1 + CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 ) + CALL DGEMV( 'Transpose', BSM, BSN-K+1, ONE, J(IBSM,K), + $ LDJ, J(IBSM,K), 1, ZERO, JTJ(II), 1 ) + JTJ(II) = JTJ(II) + C + I1 = I1 + IBSN + II = I1 + ST + IF ( ST.GT.0 ) + $ CALL DGEMV( 'Transpose', BSM, ST, ONE, J(IBSM,JL), + $ LDJ, J(IBSM,K), 1, ZERO, JTJ(I1), 1 ) + 80 CONTINUE +C + 90 CONTINUE +C +C Compute the last diagonal block. +C + DO 100 K = 1, ST + CALL DGEMV( 'Transpose', M, ST-K+1, ONE, J(1,BSN+K), LDJ, + $ J(1,BSN+K), 1, ZERO, JTJ(II), 1 ) + JTJ(II) = JTJ(II) + C + II = II + ST - K + 1 + 100 CONTINUE +C + END IF +C + END IF +C + RETURN +C +C *** Last line of NF01BU *** + END diff --git a/mex/sources/libslicot/NF01BV.f b/mex/sources/libslicot/NF01BV.f new file mode 100644 index 000000000..d596ec50a --- /dev/null +++ b/mex/sources/libslicot/NF01BV.f @@ -0,0 +1,249 @@ + SUBROUTINE NF01BV( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J, + $ LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix J'*J + c*I, for the Jacobian J as received +C from SLICOT Library routine NF01BY, for one output variable. +C +C NOTE: this routine must have the same arguments as SLICOT Library +C routine NF01BU. +C +C ARGUMENTS +C +C Mode Parameters +C +C STOR CHARACTER*1 +C Specifies the storage scheme for the symmetric +C matrix J'*J + c*I, as follows: +C = 'F' : full storage is used; +C = 'P' : packed storage is used. +C +C UPLO CHARACTER*1 +C Specifies which part of the matrix J'*J + c*I is stored, +C as follows: +C = 'U' : the upper triagular part is stored; +C = 'L' : the lower triagular part is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain the number of rows M of the Jacobian +C matrix J. M >= 0. +C IPAR is provided for compatibility with SLICOT Library +C routine MD03AD. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 1. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the problem. +C The entry DPAR(1) must contain the real scalar c. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension (LDJ,N) +C The leading M-by-N part of this array must contain the +C Jacobian matrix J. +C +C LDJ INTEGER +C The leading dimension of the array J. LDJ >= MAX(1,M). +C +C JTJ (output) DOUBLE PRECISION array, +C dimension (LDJTJ,N), if STOR = 'F', +C dimension (N*(N+1)/2), if STOR = 'P'. +C The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if +C STOR = 'P') part of this array contains the upper or +C lower triangle of the matrix J'*J + c*I, depending on +C UPLO = 'U', or UPLO = 'L', respectively, stored either as +C a two-dimensional, or one-dimensional array, depending +C on STOR. +C +C LDJTJ INTEGER +C The leading dimension of the array JTJ. +C LDJTJ >= MAX(1,N), if STOR = 'F'. +C LDJTJ >= 1, if STOR = 'P'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C Currently, this array is not used. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The matrix product is computed columnn-wise, exploiting the +C symmetry. BLAS 3 routine DSYRK is used if STOR = 'F', and BLAS 2 +C routine DGEMV is used if STOR = 'P'. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001. +C +C REVISIONS +C +C V. Sima, March 2002. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations, +C Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER STOR, UPLO + INTEGER INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), JTJ(*) +C .. Local Scalars .. + LOGICAL FULL, UPPER + INTEGER I, II, M + DOUBLE PRECISION C +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DLASET, DSYRK, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C + INFO = 0 + FULL = LSAME( STOR, 'F' ) + UPPER = LSAME( UPLO, 'U' ) +C + IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -2 + ELSEIF ( N.LT.0 ) THEN + INFO = -3 + ELSEIF ( LIPAR.LT.1 ) THEN + INFO = -5 + ELSEIF ( LDPAR.LT.1 ) THEN + INFO = -7 + ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN + INFO = -11 + ELSEIF ( LDWORK.LT.0 ) THEN + INFO = -13 + ELSE + M = IPAR(1) + IF ( M.LT.0 ) THEN + INFO = -4 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -9 + ENDIF + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BV', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + C = DPAR(1) + IF ( N.EQ.0 ) THEN + RETURN + ELSE IF ( M.EQ.0 ) THEN + IF ( FULL ) THEN + CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) + ELSE + DUM(1) = ZERO + CALL DCOPY( ( N*( N + 1 ) )/2, DUM, 0, JTJ, 1 ) + IF ( UPPER ) THEN + II = 0 +C + DO 10 I = 1, N + II = II + I + JTJ(II) = C + 10 CONTINUE +C + ELSE + II = 1 +C + DO 20 I = N, 1, -1 + JTJ(II) = C + II = II + I + 20 CONTINUE +C + ENDIF + ENDIF + RETURN + ENDIF +C +C Build a triangle of the matrix J'*J + c*I. +C + IF ( FULL ) THEN + CALL DLASET( UPLO, N, N, ZERO, C, JTJ, LDJTJ ) + CALL DSYRK( UPLO, 'Transpose', N, M, ONE, J, LDJ, ONE, JTJ, + $ LDJTJ ) + ELSEIF ( UPPER ) THEN + II = 0 +C + DO 30 I = 1, N + CALL DGEMV( 'Transpose', M, I, ONE, J, LDJ, J(1,I), 1, ZERO, + $ JTJ(II+1), 1 ) + II = II + I + JTJ(II) = JTJ(II) + C + 30 CONTINUE +C + ELSE + II = 1 +C + DO 40 I = N, 1, -1 + CALL DGEMV( 'Transpose', M, I, ONE, J(1,N-I+1), LDJ, + $ J(1,N-I+1), 1, ZERO, JTJ(II), 1 ) + JTJ(II) = JTJ(II) + C + II = II + I + 40 CONTINUE +C + ENDIF +C + RETURN +C +C *** Last line of NF01BV *** + END diff --git a/mex/sources/libslicot/NF01BW.f b/mex/sources/libslicot/NF01BW.f new file mode 100644 index 000000000..1fdac4fd9 --- /dev/null +++ b/mex/sources/libslicot/NF01BW.f @@ -0,0 +1,242 @@ + SUBROUTINE NF01BW( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrix-vector product x <-- (J'*J + c*I)*x, for the +C Jacobian J as received from SLICOT Library routine NF01BD: +C +C / dy(1)/dwb(1) | dy(1)/dtheta \ +C Jc = | : | : | . +C \ dy(L)/dwb(L) | dy(L)/dtheta / +C +C This is a compressed representation of the actual structure +C +C / J_1 0 .. 0 | L_1 \ +C | 0 J_2 .. 0 | L_2 | +C J = | : : .. : | : | . +C | : : .. : | : | +C \ 0 0 .. J_L | L_L / +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the vector x. +C N = BN*BSN + ST >= 0. (See parameter description below.) +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain ST, the number of parameters +C corresponding to the linear part. ST >= 0. +C IPAR(2) must contain BN, the number of blocks, BN = L, +C for the parameters corresponding to the nonlinear +C part. BN >= 0. +C IPAR(3) must contain BSM, the number of rows of the blocks +C J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the +C number of rows of the matrix J, if BN <= 1. +C IPAR(4) must contain BSN, the number of columns of the +C blocks J_k, k = 1:BN. BSN >= 0. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 4. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the problem. +C The entry DPAR(1) must contain the real scalar c. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension (LDJ, NC) +C where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1. +C The leading NR-by-NC part of this array must contain +C the (compressed) representation (Jc) of the Jacobian +C matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM, +C if BN > 1. +C +C LDJ (input) INTEGER +C The leading dimension of array J. LDJ >= MAX(1,NR). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*INCX) +C On entry, this incremented array must contain the +C vector x. +C On exit, this incremented array contains the value of the +C matrix-vector product (J'*J + c*I)*x. +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX >= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= NR. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The associativity of matrix multiplications is used; the result +C is obtained as: x_out = J'*( J*x ) + c*x. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Mar. 2001, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001, +C Mar. 2002. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations, +C Wiener system. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N +C .. Array Arguments .. + DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) + INTEGER IPAR(*) +C .. Local Scalars .. + INTEGER BN, BSM, BSN, IBSM, IBSN, IX, JL, M, NTHS, ST, + $ XL + DOUBLE PRECISION C +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 +C + IF ( N.LT.0 ) THEN + INFO = -1 + ELSEIF ( LIPAR.LT.4 ) THEN + INFO = -3 + ELSEIF ( LDPAR.LT.1 ) THEN + INFO = -5 + ELSEIF ( INCX.LT.1 ) THEN + INFO = -9 + ELSE + ST = IPAR(1) + BN = IPAR(2) + BSM = IPAR(3) + BSN = IPAR(4) + NTHS = BN*BSN + IF ( BN.GT.1 ) THEN + M = BN*BSM + ELSE + M = BSM + END IF + IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN + INFO = -2 + ELSEIF ( N.NE.NTHS + ST ) THEN + INFO = -1 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSEIF ( LDWORK.LT.M ) THEN + INFO = -11 + END IF + END IF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BW', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + C = DPAR(1) +C + IF ( M.EQ.0 ) THEN +C +C Special case, void Jacobian: x <-- c*x. +C + CALL DSCAL( N, C, X, INCX ) + RETURN + END IF +C + IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN +C +C Special case, l <= 1 or BSN = 0: the Jacobian is represented +C as a full matrix. Adapted code from NF01BX is included in-line. +C + CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, + $ INCX ) + RETURN + END IF +C +C General case: l > 1, BSN > 0, BSM > 0. +C + JL = BSN + 1 + IX = BSN*INCX + XL = BN*IX + 1 +C + IF ( ST.GT.0 ) THEN + CALL DGEMV( 'NoTranspose', M, ST, ONE, J(1,JL), LDJ, X(XL), + $ INCX, ZERO, DWORK, 1 ) + ELSE + DWORK(1) = ZERO + CALL DCOPY( M, DWORK(1), 0, DWORK, 1 ) + END IF + IBSN = 1 +C + DO 10 IBSM = 1, M, BSM + CALL DGEMV( 'NoTranspose', BSM, BSN, ONE, J(IBSM,1), LDJ, + $ X(IBSN), INCX, ONE, DWORK(IBSM), 1 ) + CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1), LDJ, + $ DWORK(IBSM), 1, C, X(IBSN), INCX ) + IBSN = IBSN + IX + 10 CONTINUE +C + IF ( ST.GT.0 ) + $ CALL DGEMV( 'Transpose', M, ST, ONE, J(1,JL), LDJ, DWORK, 1, C, + $ X(XL), INCX ) +C + RETURN +C +C *** Last line of NF01BW *** + END diff --git a/mex/sources/libslicot/NF01BX.f b/mex/sources/libslicot/NF01BX.f new file mode 100644 index 000000000..73cc30c61 --- /dev/null +++ b/mex/sources/libslicot/NF01BX.f @@ -0,0 +1,174 @@ + SUBROUTINE NF01BX( N, IPAR, LIPAR, DPAR, LDPAR, J, LDJ, X, INCX, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute (J'*J + c*I)*x, where J is an m-by-n real matrix, c is +C a real scalar, I is the n-by-n identity matrix, and x is a real +C n-vector. +C +C NOTE: this routine must have the same arguments as SLICOT Library +C routine NF01BW. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of columns of the Jacobian matrix J. N >= 0. +C +C IPAR (input) INTEGER array, dimension (LIPAR) +C The integer parameters describing the structure of the +C matrix J, as follows: +C IPAR(1) must contain the number of rows M of the Jacobian +C matrix J. M >= 0. +C IPAR is provided for compatibility with SLICOT Library +C routine MD03AD. +C +C LIPAR (input) INTEGER +C The length of the array IPAR. LIPAR >= 1. +C +C DPAR (input) DOUBLE PRECISION array, dimension (LDPAR) +C The real parameters needed for solving the problem. +C The entry DPAR(1) must contain the real scalar c. +C +C LDPAR (input) INTEGER +C The length of the array DPAR. LDPAR >= 1. +C +C J (input) DOUBLE PRECISION array, dimension (LDJ,N) +C The leading M-by-N part of this array must contain the +C Jacobian matrix J. +C +C LDJ INTEGER +C The leading dimension of the array J. LDJ >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension +C (1+(N-1)*abs(INCX)) +C On entry, this incremented array must contain the +C vector x. +C On exit, this incremented array contains the value of the +C matrix-vector product (J'*J + c*I)*x. +C +C INCX (input) INTEGER +C The increment for the elements of X. INCX <> 0. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= M. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The associativity of matrix multiplications is used; the result +C is obtained as: x_out = J'*( J*x ) + c*x. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Mar. 2002, Oct. 2004. +C +C KEYWORDS +C +C Elementary matrix operations, matrix algebra, matrix operations. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INCX, INFO, LDJ, LDPAR, LDWORK, LIPAR, N +C .. Array Arguments .. + INTEGER IPAR(*) + DOUBLE PRECISION DPAR(*), DWORK(*), J(LDJ,*), X(*) +C .. Local Scalars .. + INTEGER M + DOUBLE PRECISION C +C .. External Subroutines .. + EXTERNAL DGEMV, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C + INFO = 0 + IF ( N.LT.0 ) THEN + INFO = -1 + ELSEIF ( LIPAR.LT.1 ) THEN + INFO = -3 + ELSEIF ( LDPAR.LT.1 ) THEN + INFO = -5 + ELSEIF ( INCX.EQ.0 ) THEN + INFO = -9 + ELSE + M = IPAR(1) + IF ( M.LT.0 ) THEN + INFO = -2 + ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSEIF ( LDWORK.LT.M ) THEN + INFO = -11 + ENDIF + ENDIF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'NF01BX', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + C = DPAR(1) + IF ( M.EQ.0 ) THEN +C +C Special case, void J: x <-- c*x. +C + CALL DSCAL( N, C, X, INCX ) + RETURN + END IF +C + CALL DGEMV( 'NoTranspose', M, N, ONE, J, LDJ, X, INCX, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'Transpose', M, N, ONE, J, LDJ, DWORK, 1, C, X, INCX ) + RETURN +C +C *** Last line of NF01BX *** + END diff --git a/mex/sources/libslicot/NF01BY.f b/mex/sources/libslicot/NF01BY.f new file mode 100644 index 000000000..c9c0a8e33 --- /dev/null +++ b/mex/sources/libslicot/NF01BY.f @@ -0,0 +1,294 @@ + SUBROUTINE NF01BY( CJTE, NSMP, NZ, L, IPAR, LIPAR, WB, LWB, Z, + $ LDZ, E, J, LDJ, JTE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Jacobian of the error function for a neural network +C of the structure +C +C - tanh(w1*z+b1) - +C / : \ +C z --- : --- sum(ws(i)*...)+ b(n+1) --- y, +C \ : / +C - tanh(wn*z+bn) - +C +C for the single-output case. The Jacobian has the form +C +C d e(1) / d WB(1) ... d e(1) / d WB(NWB) +C J = : : , +C d e(NSMP) / d WB(1) ... d e(NSMP) / d WB(NWB) +C +C where e(z) is the error function, WB is the set of weights and +C biases of the network (for the considered output), and NWB is +C the number of elements of this set, NWB = IPAR(1)*(NZ+2)+1 +C (see below). +C +C In the multi-output case, this routine should be called for each +C output. +C +C NOTE: this routine must have the same arguments as SLICOT Library +C routine NF01BD. +C +C ARGUMENTS +C +C Mode Parameters +C +C CJTE CHARACTER*1 +C Specifies whether the matrix-vector product J'*e should be +C computed or not, as follows: +C = 'C' : compute J'*e; +C = 'N' : do not compute J'*e. +C +C Input/Output Parameters +C +C NSMP (input) INTEGER +C The number of training samples. NSMP >= 0. +C +C NZ (input) INTEGER +C The length of each input sample. NZ >= 0. +C +C L (input) INTEGER +C The length of each output sample. +C Currently, L must be 1. +C +C IPAR (input/output) INTEGER array, dimension (LIPAR) +C The integer parameters needed. +C On entry, the first element of this array must contain +C a value related to the number of neurons, n; specifically, +C n = abs(IPAR(1)), since setting IPAR(1) < 0 has a special +C meaning (see below). +C On exit, if IPAR(1) < 0 on entry, then no computations are +C performed, except the needed tests on input parameters, +C but the following values are returned: +C IPAR(1) contains the length of the array J, LJ; +C LDJ contains the leading dimension of array J. +C Otherwise, IPAR(1) and LDJ are unchanged on exit. +C +C LIPAR (input) INTEGER +C The length of the vector IPAR. LIPAR >= 1. +C +C WB (input) DOUBLE PRECISION array, dimension (LWB) +C The leading NWB = IPAR(1)*(NZ+2)+1 part of this array +C must contain the weights and biases of the network, +C WB = ( w(1,1), ..., w(1,NZ), ..., w(n,1), ..., w(n,NZ), +C ws(1), ..., ws(n), b(1), ..., b(n+1) ), +C where w(i,j) are the weights of the hidden layer, +C ws(i) are the weights of the linear output layer and +C b(i) are the biases. +C +C LWB (input) INTEGER +C The length of array WB. LWB >= NWB. +C +C Z (input) DOUBLE PRECISION array, dimension (LDZ, NZ) +C The leading NSMP-by-NZ part of this array must contain the +C set of input samples, +C Z = ( Z(1,1),...,Z(1,NZ); ...; Z(NSMP,1),...,Z(NSMP,NZ) ). +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,NSMP). +C +C E (input) DOUBLE PRECISION array, dimension (NSMP) +C If CJTE = 'C', this array must contain the error vector e. +C If CJTE = 'N', this array is not referenced. +C +C J (output) DOUBLE PRECISION array, dimension (LDJ, NWB) +C The leading NSMP-by-NWB part of this array contains the +C Jacobian of the error function. +C +C LDJ INTEGER +C The leading dimension of array J. LDJ >= MAX(1,NSMP). +C Note that LDJ is an input parameter, except for +C IPAR(1) < 0 on entry, when it is an output parameter. +C +C JTE (output) DOUBLE PRECISION array, dimension (NWB) +C If CJTE = 'C', this array contains the matrix-vector +C product J'*e. +C If CJTE = 'N', this array is not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C This argument is included for combatibility with SLICOT +C Library routine NF01BD. +C +C LDWORK INTEGER +C Normally, the length of the array DWORK. LDWORK >= 0. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Jacobian is computed analytically. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Input output description, neural network, nonlinear system, +C optimization, system response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER CJTE + INTEGER INFO, L, LDJ, LDWORK, LDZ, LIPAR, LWB, NSMP, NZ +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), E(*), J(LDJ,*), JTE(*), WB(*), + $ Z(LDZ,*) + INTEGER IPAR(*) +C .. Local Scalars .. + LOGICAL WJTE + INTEGER BP1, DI, I, IB, K, M, NN, NWB, WS + DOUBLE PRECISION BIGNUM, SMLNUM, TMP +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, EXP, LOG, MAX, MIN +C .. +C .. Executable Statements .. +C + WJTE = LSAME( CJTE, 'C' ) + INFO = 0 + NN = IPAR(1) + NWB = NN*( NZ + 2 ) + 1 + IF( .NOT.( WJTE .OR. LSAME( CJTE, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( NSMP.LT.0 ) THEN + INFO = -2 + ELSEIF ( NZ.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.NE.1 ) THEN + INFO = -4 + ELSEIF ( LIPAR.LT.1 ) THEN + INFO = -6 + ELSEIF ( IPAR(1).LT.0 ) THEN + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BY', -INFO ) + ELSE + IPAR(1) = NSMP*( ABS( NN )*( NZ + 2 ) + 1 ) + LDJ = NSMP + ENDIF + RETURN + ELSEIF ( LWB.LT.NWB ) THEN + INFO = -8 + ELSEIF ( LDZ.LT.MAX( 1, NSMP ) ) THEN + INFO = -10 + ELSEIF ( LDJ.LT.MAX( 1, NSMP ) ) THEN + INFO = -13 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'NF01BY', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MIN( NSMP, NZ ).EQ.0 ) + $ RETURN +C +C Set parameters to avoid overflows and increase accuracy for +C extreme values. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = LOG( SMLNUM ) + BIGNUM = LOG( BIGNUM ) +C + WS = NZ*NN + 1 + IB = WS + NN + BP1 = IB + NN +C + J(1, BP1) = ONE + CALL DCOPY( NSMP, J(1, BP1), 0, J(1, BP1), 1 ) +C + DO 10 I = 0, NN - 1 + CALL DCOPY( NSMP, WB(IB+I), 0, J(1, WS+I), 1 ) + 10 CONTINUE +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NSMP, NN, NZ, -TWO, Z, + $ LDZ, WB, NZ, -TWO, J(1, WS), LDJ ) + DI = 1 +C + DO 50 I = 0, NN - 1 +C + DO 20 K = 1, NSMP + TMP = J(K, WS+I) + IF ( ABS( TMP ).GE.BIGNUM ) THEN + IF ( TMP.GT.ZERO ) THEN + J(K, WS+I) = -ONE + ELSE + J(K, WS+I) = ONE + END IF + ELSE IF ( ABS( TMP ).LE.SMLNUM ) THEN + J(K, WS+I) = ZERO + ELSE + J(K, WS+I) = TWO/( ONE + EXP( TMP ) ) - ONE + END IF + J(K, IB+I) = WB(WS+I)*( ONE - J(K, WS+I)**2 ) + 20 CONTINUE +C + DO 40 K = 0, NZ - 1 +C + DO 30 M = 1, NSMP + J(M, DI+K) = J(M, IB+I)*Z(M, K+1) + 30 CONTINUE +C + 40 CONTINUE +C + DI = DI + NZ + 50 CONTINUE +C + IF ( WJTE ) THEN +C +C Compute J'e. +C + CALL DGEMV( 'Transpose', NSMP, NWB, ONE, J, LDJ, E, 1, ZERO, + $ JTE, 1 ) + END IF +C + RETURN +C +C *** Last line of NF01BY *** + END diff --git a/mex/sources/libslicot/SB01BD.f b/mex/sources/libslicot/SB01BD.f new file mode 100644 index 000000000..587581e34 --- /dev/null +++ b/mex/sources/libslicot/SB01BD.f @@ -0,0 +1,776 @@ + SUBROUTINE SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB, WR, WI, + $ NFP, NAP, NUP, F, LDF, Z, LDZ, TOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine the state feedback matrix F for a given system (A,B) +C such that the closed-loop state matrix A+B*F has specified +C eigenvalues. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrix B and +C the number of columns of the matrix F. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrix B and the number of rows of the matrix F. +C M >= 0. +C +C NP (input) INTEGER +C The number of given eigenvalues. At most N eigenvalues +C can be assigned. 0 <= NP. +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the maximum admissible value, either for real +C parts, if DICO = 'C', or for moduli, if DICO = 'D', +C of the eigenvalues of A which will not be modified by +C the eigenvalue assignment algorithm. +C ALPHA >= 0 if DICO = 'D'. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Z'*(A+B*F)*Z in a real Schur form. +C The leading NFP-by-NFP diagonal block of A corresponds +C to the fixed (unmodified) eigenvalues having real parts +C less than ALPHA, if DICO = 'C', or moduli less than ALPHA, +C if DICO = 'D'. The trailing NUP-by-NUP diagonal block of A +C corresponds to the uncontrollable eigenvalues detected by +C the eigenvalue assignment algorithm. The elements under +C the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C WR,WI (input/output) DOUBLE PRECISION array, dimension (NP) +C On entry, these arrays must contain the real and imaginary +C parts, respectively, of the desired eigenvalues of the +C closed-loop system state-matrix A+B*F. The eigenvalues +C can be unordered, except that complex conjugate pairs +C must appear consecutively in these arrays. +C On exit, if INFO = 0, the leading NAP elements of these +C arrays contain the real and imaginary parts, respectively, +C of the assigned eigenvalues. The trailing NP-NAP elements +C contain the unassigned eigenvalues. +C +C NFP (output) INTEGER +C The number of eigenvalues of A having real parts less than +C ALPHA, if DICO = 'C', or moduli less than ALPHA, if +C DICO = 'D'. These eigenvalues are not modified by the +C eigenvalue assignment algorithm. +C +C NAP (output) INTEGER +C The number of assigned eigenvalues. If INFO = 0 on exit, +C then NAP = N-NFP-NUP. +C +C NUP (output) INTEGER +C The number of uncontrollable eigenvalues detected by the +C eigenvalue assignment algorithm (see METHOD). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the state +C feedback F, which assigns NAP closed-loop eigenvalues and +C keeps unaltered N-NAP open-loop eigenvalues. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the +C orthogonal matrix Z which reduces the closed-loop +C system state matrix A + B*F to upper real Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of A +C or B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then the default tolerance +C TOL = N * EPS * max(NORM(A),NORM(B)) is used, where EPS is +C the machine precision (see LAPACK Library routine DLAMCH) +C and NORM(A) denotes the 1-norm of A. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1,5*M,5*N,2*N+4*M ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(F) <= 100*NORM(A)/NORM(B) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal. +C = 3: the number of eigenvalues to be assigned is less +C than the number of possibly assignable eigenvalues; +C NAP eigenvalues have been properly assigned, +C but some assignable eigenvalues remain unmodified. +C = 4: an attempt is made to place a complex conjugate +C pair on the location of a real eigenvalue. This +C situation can only appear when N-NFP is odd, +C NP > N-NFP-NUP is even, and for the last real +C eigenvalue to be modified there exists no available +C real eigenvalue to be assigned. However, NAP +C eigenvalues have been already properly assigned. +C +C METHOD +C +C SB01BD is based on the factorization algorithm of [1]. +C Given the matrices A and B of dimensions N-by-N and N-by-M, +C respectively, this subroutine constructs an M-by-N matrix F such +C that A + BF has eigenvalues as follows. +C Let NFP eigenvalues of A have real parts less than ALPHA, if +C DICO = 'C', or moduli less then ALPHA, if DICO = 'D'. Then: +C 1) If the pair (A,B) is controllable, then A + B*F has +C NAP = MIN(NP,N-NFP) eigenvalues assigned from those specified +C by WR + j*WI and N-NAP unmodified eigenvalues; +C 2) If the pair (A,B) is uncontrollable, then the number of +C assigned eigenvalues NAP satifies generally the condition +C NAP <= MIN(NP,N-NFP). +C +C At the beginning of the algorithm, F = 0 and the matrix A is +C reduced to an ordered real Schur form by separating its spectrum +C in two parts. The leading NFP-by-NFP part of the Schur form of +C A corresponds to the eigenvalues which will not be modified. +C These eigenvalues have real parts less than ALPHA, if +C DICO = 'C', or moduli less than ALPHA, if DICO = 'D'. +C The performed orthogonal transformations are accumulated in Z. +C After this preliminary reduction, the algorithm proceeds +C recursively. +C +C Let F be the feedback matrix at the beginning of a typical step i. +C At each step of the algorithm one real eigenvalue or two complex +C conjugate eigenvalues are placed by a feedback Fi of rank 1 or +C rank 2, respectively. Since the feedback Fi affects only the +C last 1 or 2 columns of Z'*(A+B*F)*Z, the matrix Z'*(A+B*F+B*Fi)*Z +C therefore remains in real Schur form. The assigned eigenvalue(s) +C is (are) then moved to another diagonal position of the real +C Schur form using reordering techniques and a new block is +C transfered in the last diagonal position. The feedback matrix F +C is updated as F <-- F + Fi. The eigenvalue(s) to be assigned at +C each step is (are) chosen such that the norm of each Fi is +C minimized. +C +C If uncontrollable eigenvalues are encountered in the last diagonal +C position of the real Schur matrix Z'*(A+B*F)*Z, the algorithm +C deflates them at the bottom of the real Schur form and redefines +C accordingly the position of the "last" block. +C +C Note: Not all uncontrollable eigenvalues of the pair (A,B) are +C necessarily detected by the eigenvalue assignment algorithm. +C Undetected uncontrollable eigenvalues may exist if NFP > 0 and/or +C NP < N-NFP. +C +C REFERENCES +C +C [1] Varga A. +C A Schur method for pole assignment. +C IEEE Trans. Autom. Control, Vol. AC-26, pp. 517-519, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. Although no proof of numerical stability is known, +C the algorithm has always been observed to yield reliable +C numerical results. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routine SB01BD. +C +C REVISIONS +C +C March 30, 1999, V. Sima, Research Institute for Informatics, +C Bucharest. +C April 4, 1999. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C May 18, 2003. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C Feb. 15, 2004, V. Sima, Research Institute for Informatics, +C Bucharest. +C May 12, 2005. A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Eigenvalues, eigenvalue assignment, feedback control, +C pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HUNDR, ONE, TWO, ZERO + PARAMETER ( HUNDR = 1.0D2, ONE = 1.0D0, TWO = 2.0D0, + $ ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDF, LDWORK, LDZ, M, N, + $ NAP, NFP, NP, NUP + DOUBLE PRECISION ALPHA, TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), + $ WI(*), WR(*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL CEIG, DISCR, SIMPLB + INTEGER I, IB, IB1, IERR, IPC, J, K, KFI, KG, KW, KWI, + $ KWR, NCUR, NCUR1, NL, NLOW, NMOVES, NPC, NPR, + $ NSUP, WRKOPT + DOUBLE PRECISION ANORM, BNORM, C, P, RMAX, S, X, Y, TOLER, TOLERB +C .. Local Arrays .. + LOGICAL BWORK(1) + DOUBLE PRECISION A2(2,2) +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLAEXC, DLASET, DROT, DSWAP, + $ MB03QD, MB03QY, SB01BX, SB01BY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( NP.LT.0 ) THEN + INFO = -4 + ELSE IF( DISCR .AND. ( ALPHA.LT.ZERO ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, 5*M, 5*N, 2*N + 4*M ) ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB01BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + NFP = 0 + NAP = 0 + NUP = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Compute the norms of A and B, and set default tolerances +C if necessary. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + IF( TOL.LE.ZERO ) THEN + X = DLAMCH( 'Epsilon' ) + TOLER = DBLE( N ) * MAX( ANORM, BNORM ) * X + TOLERB = DBLE( N ) * BNORM * X + ELSE + TOLER = TOL + TOLERB = TOL + END IF +C +C Allocate working storage. +C + KWR = 1 + KWI = KWR + N + KW = KWI + N +C +C Reduce A to real Schur form using an orthogonal similarity +C transformation A <- Z'*A*Z and accumulate the transformation in Z. +C +C Workspace: need 5*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'No ordering', SELECT, N, A, LDA, NCUR, + $ DWORK(KWR), DWORK(KWI), Z, LDZ, DWORK(KW), + $ LDWORK-KW+1, BWORK, INFO ) + WRKOPT = KW - 1 + INT( DWORK( KW ) ) + IF( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- Z'*A*Z and accumulate the +C transformations in Z. The separation of the spectrum of A is +C performed such that the leading NFP-by-NFP submatrix of A +C corresponds to the "good" eigenvalues which will not be +C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A +C corresponds to the "bad" eigenvalues to be modified. +C +C Workspace needed: N. +C + CALL MB03QD( DICO, 'Stable', 'Update', N, 1, N, ALPHA, + $ A, LDA, Z, LDZ, NFP, DWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C +C Set F = 0. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, F, LDF ) +C +C Return if B is negligible (uncontrollable system). +C + IF( BNORM.LE.TOLERB ) THEN + NAP = 0 + NUP = N + DWORK(1) = WRKOPT + RETURN + END IF +C +C Compute the bound for the numerical stability condition. +C + RMAX = HUNDR * ANORM / BNORM +C +C Perform eigenvalue assignment if there exist "bad" eigenvalues. +C + NAP = 0 + NUP = 0 + IF( NFP .LT. N ) THEN + KG = 1 + KFI = KG + 2*M + KW = KFI + 2*M +C +C Set the limits for the bottom diagonal block. +C + NLOW = NFP + 1 + NSUP = N +C +C Separate and count real and complex eigenvalues to be assigned. +C + NPR = 0 + DO 10 I = 1, NP + IF( WI(I) .EQ. ZERO ) THEN + NPR = NPR + 1 + K = I - NPR + IF( K .GT. 0 ) THEN + S = WR(I) + DO 5 J = NPR + K - 1, NPR, -1 + WR(J+1) = WR(J) + WI(J+1) = WI(J) + 5 CONTINUE + WR(NPR) = S + WI(NPR) = ZERO + END IF + END IF + 10 CONTINUE + NPC = NP - NPR +C +C The first NPR elements of WR and WI contain the real +C eigenvalues, the last NPC elements contain the complex +C eigenvalues. Set the pointer to complex eigenvalues. +C + IPC = NPR + 1 +C +C Main loop for assigning one or two eigenvalues. +C +C Terminate if all eigenvalues were assigned, or if there +C are no more eigenvalues to be assigned, or if a non-fatal +C error condition was set. +C +C WHILE (NLOW <= NSUP and INFO = 0) DO +C + 20 IF( NLOW.LE.NSUP .AND. INFO.EQ.0 ) THEN +C +C Determine the dimension of the last block. +C + IB = 1 + IF( NLOW.LT.NSUP ) THEN + IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 + END IF +C +C Compute G, the current last IB rows of Z'*B. +C + NL = NSUP - IB + 1 + CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, + $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) +C +C Check the controllability for a simple block. +C + IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) + $ .LE. TOLERB ) THEN +C +C Deflate the uncontrollable block and resume the +C main loop. +C + NSUP = NSUP - IB + NUP = NUP + IB + GO TO 20 + END IF +C +C Test for termination with INFO = 3. +C + IF( NAP.EQ.NP) THEN + INFO = 3 +C +C Test for compatibility. Terminate if an attempt occurs +C to place a complex conjugate pair on a 1x1 block. +C + ELSE IF( IB.EQ.1 .AND. NPR.EQ.0 .AND. NLOW.EQ.NSUP ) THEN + INFO = 4 + ELSE +C +C Set the simple block flag. +C + SIMPLB = .TRUE. +C +C Form a 2-by-2 block if necessary from two 1-by-1 blocks. +C Consider special case IB = 1, NPR = 1 and +C NPR+NPC > NSUP-NLOW+1 to avoid incompatibility. +C + IF( ( IB.EQ.1 .AND. NPR.EQ.0 ) .OR. + $ ( IB.EQ.1 .AND. NPR.EQ.1 .AND. NSUP.GT.NLOW .AND. + $ NPR+NPC.GT.NSUP-NLOW+1 ) ) THEN + IF( NSUP.GT.2 ) THEN + IF( A(NSUP-1,NSUP-2) .NE. ZERO ) THEN +C +C Interchange with the adjacent 2x2 block. +C +C Workspace needed: N. +C + CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, NSUP-2, + $ 2, 1, DWORK(KW), INFO ) + IF( INFO .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + ELSE +C +C Form a non-simple block by extending the last +C block with a 1x1 block. +C + SIMPLB = .FALSE. + END IF + ELSE + SIMPLB = .FALSE. + END IF + IB = 2 + END IF + NL = NSUP - IB + 1 +C +C Compute G, the current last IB rows of Z'*B. +C + CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE, + $ Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB ) +C +C Check the controllability for the current block. +C + IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) ) + $ .LE. TOLERB ) THEN +C +C Deflate the uncontrollable block and resume the +C main loop. +C + NSUP = NSUP - IB + NUP = NUP + IB + GO TO 20 + END IF +C + IF( NAP+IB .GT. NP ) THEN +C +C No sufficient eigenvalues to be assigned. +C + INFO = 3 + ELSE + IF( IB .EQ. 1 ) THEN +C +C A 1-by-1 block. +C +C Assign the real eigenvalue nearest to A(NSUP,NSUP). +C + X = A(NSUP,NSUP) + CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) + NPR = NPR - 1 + CEIG = .FALSE. + ELSE +C +C A 2-by-2 block. +C + IF( SIMPLB ) THEN +C +C Simple 2-by-2 block with complex eigenvalues. +C Compute the eigenvalues of the last block. +C + CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, INFO ) + IF( NPC .GT. 1 ) THEN + CALL SB01BX( .FALSE., NPC, X, Y, + $ WR(IPC), WI(IPC), S, P ) + NPC = NPC - 2 + CEIG = .TRUE. + ELSE +C +C Choose the nearest two real eigenvalues. +C + CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P ) + CALL SB01BX( .TRUE., NPR-1, X, X, WR, X, + $ Y, P ) + P = S * Y + S = S + Y + NPR = NPR - 2 + CEIG = .FALSE. + END IF + ELSE +C +C Non-simple 2x2 block with real eigenvalues. +C Choose the nearest pair of complex eigenvalues. +C + X = ( A(NL,NL) + A(NSUP,NSUP) )/TWO + CALL SB01BX( .FALSE., NPC, X, ZERO, WR(IPC), + $ WI(IPC), S, P ) + NPC = NPC - 2 + END IF + END IF +C +C Form the IBxIB matrix A2 from the current diagonal +C block. +C + A2(1,1) = A(NL,NL) + IF( IB .GT. 1 ) THEN + A2(1,2) = A(NL,NSUP) + A2(2,1) = A(NSUP,NL) + A2(2,2) = A(NSUP,NSUP) + END IF +C +C Determine the M-by-IB feedback matrix FI which +C assigns the chosen IB eigenvalues for the pair (A2,G). +C +C Workspace needed: 5*M. +C + CALL SB01BY( IB, M, S, P, A2, DWORK(KG), DWORK(KFI), + $ TOLER, DWORK(KW), IERR ) + IF( IERR .NE. 0 ) THEN + IF( IB.EQ.1 .OR. SIMPLB ) THEN +C +C The simple 1x1 block is uncontrollable. +C + NSUP = NSUP - IB + IF( CEIG ) THEN + NPC = NPC + IB + ELSE + NPR = NPR + IB + END IF + NUP = NUP + IB + ELSE +C +C The non-simple 2x2 block is uncontrollable. +C Eliminate its uncontrollable part by using +C the information in elements FI(1,1) and F(1,2). +C + C = DWORK(KFI) + S = DWORK(KFI+IB) +C +C Apply the transformation to A and accumulate it +C in Z. +C + CALL DROT( N-NL+1, A(NL,NL), LDA, + $ A(NSUP,NL), LDA, C, S ) + CALL DROT( N, A(1,NL), 1, A(1,NSUP), 1, C, S ) + CALL DROT( N, Z(1,NL), 1, Z(1,NSUP), 1, C, S ) +C +C Annihilate the subdiagonal element of the last +C block, redefine the upper limit for the bottom +C block and resume the main loop. +C + A(NSUP,NL) = ZERO + NSUP = NL + NUP = NUP + 1 + NPC = NPC + 2 + END IF + ELSE +C +C Successful assignment of IB eigenvalues. +C +C Update the feedback matrix F <-- F + [0 FI]*Z'. +C + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, + $ IB, ONE, DWORK(KFI), M, Z(1,NL), + $ LDZ, ONE, F, LDF ) +C +C Check for possible numerical instability. +C + IF( DLANGE( '1', M, IB, DWORK(KFI), M, DWORK(KW) ) + $ .GT. RMAX ) IWARN = IWARN + 1 +C +C Update the state matrix A <-- A + Z'*B*[0 FI]. +C Workspace needed: 2*N+4*M. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, IB, + $ M, ONE, B, LDB, DWORK(KFI), M, ZERO, + $ DWORK(KW), N ) + CALL DGEMM( 'Transpose', 'NoTranspose', NSUP, + $ IB, N, ONE, Z, LDZ, DWORK(KW), N, + $ ONE, A(1,NL), LDA ) +C +C Try to split the 2x2 block. +C + IF( IB .EQ. 2 ) + $ CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, + $ INFO ) + NAP = NAP + IB + IF( NLOW+IB.LE.NSUP ) THEN +C +C Move the last block(s) to the leading +C position(s) of the bottom block. +C + NCUR1 = NSUP - IB + NMOVES = 1 + IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN + IB = 1 + NMOVES = 2 + END IF +C +C WHILE (NMOVES > 0) DO + 30 IF( NMOVES .GT. 0 ) THEN + NCUR = NCUR1 +C +C WHILE (NCUR >= NLOW) DO + 40 IF( NCUR .GE. NLOW ) THEN +C +C Loop for the last block positioning. +C + IB1 = 1 + IF( NCUR.GT.NLOW ) THEN + IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 + END IF + CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, + $ NCUR-IB1+1, IB1, IB, + $ DWORK(KW), INFO ) + IF( INFO .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + NCUR = NCUR - IB1 + GO TO 40 + END IF +C +C END WHILE 40 +C + NMOVES = NMOVES - 1 + NCUR1 = NCUR1 + 1 + NLOW = NLOW + IB + GO TO 30 + END IF +C +C END WHILE 30 +C + ELSE + NLOW = NLOW + IB + END IF + END IF + END IF + END IF + IF( INFO.EQ.0 ) GO TO 20 +C +C END WHILE 20 +C + END IF +C + WRKOPT = MAX( WRKOPT, 5*M, 2*N + 4*M ) + END IF +C +C Annihilate the elements below the first subdiagonal of A. +C + IF( N .GT. 2) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF( NAP .GT. 0 ) THEN +C +C Move the assigned eigenvalues in the first NAP positions of +C WR and WI. +C + K = IPC - NPR - 1 + IF( K .GT. 0 ) CALL DSWAP( K, WR(NPR+1), 1, WR, 1 ) + J = NAP - K + IF( J .GT. 0 ) THEN + CALL DSWAP( J, WR(IPC+NPC), 1, WR(K+1), 1 ) + CALL DSWAP( J, WI(IPC+NPC), 1, WI(K+1), 1 ) + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB01BD *** + END diff --git a/mex/sources/libslicot/SB01BX.f b/mex/sources/libslicot/SB01BX.f new file mode 100644 index 000000000..86812da08 --- /dev/null +++ b/mex/sources/libslicot/SB01BX.f @@ -0,0 +1,150 @@ + SUBROUTINE SB01BX( REIG, N, XR, XI, WR, WI, S, P ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To choose a real eigenvalue or a pair of complex conjugate +C eigenvalues at "minimal" distance to a given real or complex +C value. +C +C ARGUMENTS +C +C Mode Parameters +C +C REIG LOGICAL +C Specifies the type of eigenvalues as follows: +C = .TRUE., a real eigenvalue is to be selected; +C = .FALSE., a pair of complex eigenvalues is to be +C selected. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of eigenvalues contained in the arrays WR +C and WI. N >= 1. +C +C XR,XI (input) DOUBLE PRECISION +C If REIG = .TRUE., XR must contain the real value and XI +C is assumed zero and therefore not referenced. +C If REIG = .FALSE., XR must contain the real part and XI +C the imaginary part, respectively, of the complex value. +C +C WR,WI (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, if REIG = .TRUE., WR must contain the real +C eigenvalues from which an eigenvalue at minimal distance +C to XR is to be selected. In this case, WI is considered +C zero and therefore not referenced. +C On entry, if REIG = .FALSE., WR and WI must contain the +C real and imaginary parts, respectively, of the eigenvalues +C from which a pair of complex conjugate eigenvalues at +C minimal "distance" to XR + jXI is to be selected. +C The eigenvalues of each pair of complex conjugate +C eigenvalues must appear consecutively. +C On exit, the elements of these arrays are reordered such +C that the selected eigenvalue(s) is (are) found in the +C last element(s) of these arrays. +C +C S,P (output) DOUBLE PRECISION +C If REIG = .TRUE., S (and also P) contains the value of +C the selected real eigenvalue. +C If REIG = .FALSE., S and P contain the sum and product, +C respectively, of the selected complex conjugate pair of +C eigenvalues. +C +C FURTHER COMMENTS +C +C For efficiency reasons, |x| + |y| is used for a complex number +C x + jy, instead of its modulus. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C February 1999. Based on the RASP routine PMDIST. +C +C REVISIONS +C +C March 30, 1999, V. Sima, Research Institute for Informatics, +C Bucharest. +C Feb. 15, 2004, V. Sima, Research Institute for Informatics, +C Bucharest. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + LOGICAL REIG + INTEGER N + DOUBLE PRECISION P, S, XI ,XR +C .. Array Arguments .. + DOUBLE PRECISION WI(*), WR(*) +C .. Local Scalars .. + INTEGER I, J, K + DOUBLE PRECISION X, Y +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + J = 1 + IF( REIG ) THEN + Y = ABS( WR(1)-XR ) + DO 10 I = 2, N + X = ABS( WR(I)-XR ) + IF( X .LT. Y ) THEN + Y = X + J = I + END IF + 10 CONTINUE + S = WR(J) + K = N - J + IF( K .GT. 0 ) THEN + DO 20 I = J, J + K - 1 + WR(I) = WR(I+1) + 20 CONTINUE + WR(N) = S + END IF + P = S + ELSE + Y = ABS( WR(1)-XR ) + ABS( WI(1)-XI ) + DO 30 I = 3, N, 2 + X = ABS( WR(I)-XR ) + ABS( WI(I)-XI ) + IF( X .LT. Y ) THEN + Y = X + J = I + END IF + 30 CONTINUE + X = WR(J) + Y = WI(J) + K = N - J - 1 + IF( K .GT. 0 ) THEN + DO 40 I = J, J + K - 1 + WR(I) = WR(I+2) + WI(I) = WI(I+2) + 40 CONTINUE + WR(N-1) = X + WI(N-1) = Y + WR(N) = X + WI(N) = -Y + END IF + S = X + X + P = X * X + Y * Y + END IF +C + RETURN +C *** End of SB01BX *** + END diff --git a/mex/sources/libslicot/SB01BY.f b/mex/sources/libslicot/SB01BY.f new file mode 100644 index 000000000..58b480138 --- /dev/null +++ b/mex/sources/libslicot/SB01BY.f @@ -0,0 +1,332 @@ + SUBROUTINE SB01BY( N, M, S, P, A, B, F, TOL, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve an N-by-N pole placement problem for the simple cases +C N = 1 or N = 2: given the N-by-N matrix A and N-by-M matrix B, +C construct an M-by-N matrix F such that A + B*F has prescribed +C eigenvalues. These eigenvalues are specified by their sum S and +C product P (if N = 2). The resulting F has minimum Frobenius norm. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and also the number of rows of +C the matrix B and the number of columns of the matrix F. +C N is either 1, if a single real eigenvalue is prescribed +C or 2, if a complex conjugate pair or a set of two real +C eigenvalues are prescribed. +C +C M (input) INTEGER +C The number of columns of the matrix B and also the number +C of rows of the matrix F. M >= 1. +C +C S (input) DOUBLE PRECISION +C The sum of the prescribed eigenvalues if N = 2 or the +C value of prescribed eigenvalue if N = 1. +C +C P (input) DOUBLE PRECISION +C The product of the prescribed eigenvalues if N = 2. +C Not referenced if N = 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (N,N) +C On entry, this array must contain the N-by-N state +C dynamics matrix whose eigenvalues have to be moved to +C prescribed locations. +C On exit, this array contains no useful information. +C +C B (input/output) DOUBLE PRECISION array, dimension (N,M) +C On entry, this array must contain the N-by-M input/state +C matrix B. +C On exit, this array contains no useful information. +C +C F (output) DOUBLE PRECISION array, dimension (M,N) +C The state feedback matrix F which assigns one pole or two +C poles of the closed-loop matrix A + B*F. +C If N = 2 and the pair (A,B) is not controllable +C (INFO = 1), then F(1,1) and F(1,2) contain the elements of +C an orthogonal rotation which can be used to remove the +C uncontrollable part of the pair (A,B). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of A +C and B are considered zero (used for controllability test). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if uncontrollability of the pair (A,B) is detected. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine SB01BY. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C May 2003, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Eigenvalue, eigenvalue assignment, feedback control, pole +C placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION FOUR, ONE, THREE, TWO, ZERO + PARAMETER ( FOUR = 4.0D0, ONE = 1.0D0, THREE = 3.0D0, + $ TWO = 2.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M, N + DOUBLE PRECISION P, S, TOL +C .. Array Arguments .. + DOUBLE PRECISION A(N,*), B(N,*), DWORK(*), F(M,*) +C .. Local Scalars .. + INTEGER IR, J + DOUBLE PRECISION ABSR, B1, B2, B21, C, C0, C1, C11, C12, C21, + $ C22, C3, C4, CS, CU, CV, DC0, DC2, DC3, DIFFR, + $ R, RN, S12, S21, SIG, SN, SU, SV, TAU1, TAU2, + $ WI, WI1, WR, WR1, X, Y, Z +C .. External Functions .. + DOUBLE PRECISION DLAMC3, DLAMCH + EXTERNAL DLAMC3, DLAMCH +C .. External Subroutines .. + EXTERNAL DLANV2, DLARFG, DLASET, DLASV2, DLATZM, DROT +C .. Intrinsic Functions .. + INTRINSIC ABS, MIN +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + INFO = 0 + IF( N.EQ.1 ) THEN +C +C The case N = 1. +C + IF( M.GT.1 ) + $ CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) + B1 = B(1,1) + IF( ABS( B1 ).LE.TOL ) THEN +C +C The pair (A,B) is uncontrollable. +C + INFO = 1 + RETURN + END IF +C + F(1,1) = ( S - A(1,1) )/B1 + IF( M.GT.1 ) THEN + CALL DLASET( 'Full', M-1, 1, ZERO, ZERO, F(2,1), M ) + CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), + $ M, DWORK ) + END IF + RETURN + END IF +C +C In the sequel N = 2. +C +C Compute the singular value decomposition of B in the form +C +C ( V 0 ) ( B1 0 ) +C B = U*( G1 0 )*( )*H2*H1 , G1 = ( ), +C ( 0 I ) ( 0 B2 ) +C +C ( CU SU ) ( CV SV ) +C where U = ( ) and V = ( ) are orthogonal +C (-SU CU ) (-SV CV ) +C +C rotations and H1 and H2 are elementary Householder reflectors. +C ABS(B1) and ABS(B2) are the singular values of matrix B, +C with ABS(B1) >= ABS(B2). +C +C Reduce first B to the lower bidiagonal form ( B1 0 ... 0 ). +C ( B21 B2 ... 0 ) + IF( M.EQ.1 ) THEN +C +C Initialization for the case M = 1; no reduction required. +C + B1 = B(1,1) + B21 = B(2,1) + B2 = ZERO + ELSE +C +C Postmultiply B with elementary Householder reflectors H1 +C and H2. +C + CALL DLARFG( M, B(1,1), B(1,2), N, TAU1 ) + CALL DLATZM( 'Right', N-1, M, B(1,2), N, TAU1, B(2,1), B(2,2), + $ N, DWORK ) + B1 = B(1,1) + B21 = B(2,1) + IF( M.GT.2 ) + $ CALL DLARFG( M-1, B(2,2), B(2,3), N, TAU2 ) + B2 = B(2,2) + END IF +C +C Reduce B to a diagonal form by premultiplying and postmultiplying +C it with orthogonal rotations U and V, respectively, and order the +C diagonal elements to have decreasing magnitudes. +C Note: B2 has been set to zero if M = 1. Thus in the following +C computations the case M = 1 need not to be distinguished. +C Note also that LAPACK routine DLASV2 assumes an upper triangular +C matrix, so the results should be adapted. +C + CALL DLASV2( B1, B21, B2, X, Y, SU, CU, SV, CV ) + SU = -SU + B1 = Y + B2 = X +C +C Compute A1 = U'*A*U. +C + CALL DROT( 2, A(2,1), 2, A(1,1), 2, CU, SU ) + CALL DROT( 2, A(1,2), 1, A(1,1), 1, CU, SU ) +C +C Compute the rank of B and check the controllability of the +C pair (A,B). +C + IR = 0 + IF( ABS( B2 ).GT.TOL ) IR = IR + 1 + IF( ABS( B1 ).GT.TOL ) IR = IR + 1 + IF( IR.EQ.0 .OR. ( IR.EQ.1 .AND. ABS( A(2,1) ).LE.TOL ) ) THEN + F(1,1) = CU + F(1,2) = -SU +C +C The pair (A,B) is uncontrollable. +C + INFO = 1 + RETURN + END IF +C +C Compute F1 which assigns N poles for the reduced pair (A1,G1). +C + X = DLAMC3( B1, B2 ) + IF( X.EQ.B1 ) THEN +C +C Rank one G1. +C + F(1,1) = ( S - ( A(1,1) + A(2,2) ) )/B1 + F(1,2) = -( A(2,2)*( A(2,2) - S ) + A(2,1)*A(1,2) + P )/ + $ A(2,1)/B1 + IF( M.GT.1 ) THEN + F(2,1) = ZERO + F(2,2) = ZERO + END IF + ELSE +C +C Rank two G1. +C + Z = ( S - ( A(1,1) + A(2,2) ) )/( B1*B1 + B2*B2 ) + F(1,1) = B1*Z + F(2,2) = B2*Z +C +C Compute an approximation for the minimum norm parameter +C selection. +C + X = A(1,1) + B1*F(1,1) + C = X*( S - X ) - P + IF( C.GE.ZERO ) THEN + SIG = ONE + ELSE + SIG = -ONE + END IF + S12 = B1/B2 + S21 = B2/B1 + C11 = ZERO + C12 = ONE + C21 = SIG*S12*C + C22 = A(1,2) - SIG*S12*A(2,1) + CALL DLANV2( C11, C12, C21, C22, WR, WI, WR1, WI1, CS, SN ) + IF( ABS( WR - A(1,2) ).GT.ABS( WR1 - A(1,2) ) ) THEN + R = WR1 + ELSE + R = WR + END IF +C +C Perform Newton iteration to solve the equation for minimum. +C + C0 = -C*C + C1 = C*A(2,1) + C4 = S21*S21 + C3 = -C4*A(1,2) + DC0 = C1 + DC2 = THREE*C3 + DC3 = FOUR*C4 +C + DO 10 J = 1, 10 + X = C0 + R*( C1 + R*R*( C3 + R*C4 ) ) + Y = DC0 + R*R*( DC2 + R*DC3 ) + IF( Y.EQ.ZERO ) GO TO 20 + RN = R - X/Y + ABSR = ABS( R ) + DIFFR = ABS( R - RN ) + Z = DLAMC3( ABSR, DIFFR ) + IF( Z.EQ.ABSR ) + $ GO TO 20 + R = RN + 10 CONTINUE +C + 20 CONTINUE + IF( R.EQ.ZERO ) R = DLAMCH( 'Epsilon' ) + F(1,2) = ( R - A(1,2) )/B1 + F(2,1) = ( C/R - A(2,1) )/B2 + END IF +C +C Back-transform F1. Compute first F1*U'. +C + CALL DROT( MIN( M, 2 ), F(1,1), 1, F(1,2), 1, CU, SU ) + IF( M.EQ.1 ) + $ RETURN +C +C Compute V'*F1. +C + CALL DROT( 2, F(2,1), M, F(1,1), M, CV, SV ) +C +C ( F1 ) +C Form F = ( ) . +C ( 0 ) +C + IF( M.GT.N ) + $ CALL DLASET( 'Full', M-N, N, ZERO, ZERO, F(N+1,1), M ) +C +C Compute H1*H2*F. +C + IF( M.GT.2 ) + $ CALL DLATZM( 'Left', M-1, N, B(2,3), N, TAU2, F(2,1), F(3,1), + $ M, DWORK ) + CALL DLATZM( 'Left', M, N, B(1,2), N, TAU1, F(1,1), F(2,1), M, + $ DWORK ) +C + RETURN +C *** Last line of SB01BY *** + END diff --git a/mex/sources/libslicot/SB01DD.f b/mex/sources/libslicot/SB01DD.f new file mode 100644 index 000000000..15ab1b8e9 --- /dev/null +++ b/mex/sources/libslicot/SB01DD.f @@ -0,0 +1,643 @@ + SUBROUTINE SB01DD( N, M, INDCON, A, LDA, B, LDB, NBLK, WR, WI, + $ Z, LDZ, Y, COUNT, G, LDG, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for a controllable matrix pair ( A, B ) a matrix G +C such that the matrix A - B*G has the desired eigenstructure, +C specified by desired eigenvalues and free eigenvector elements. +C +C The pair ( A, B ) should be given in orthogonal canonical form +C as returned by the SLICOT Library routine AB01ND. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and the number of rows of the +C matrix B. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix B. M >= 0. +C +C INDCON (input) INTEGER +C The controllability index of the pair ( A, B ). +C 0 <= INDCON <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N matrix A in orthogonal canonical form, +C as returned by SLICOT Library routine AB01ND. +C On exit, the leading N-by-N part of this array contains +C the real Schur form of the matrix A - B*G. +C The elements below the real Schur form of A are set to +C zero. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the N-by-M matrix B in orthogonal canonical form, +C as returned by SLICOT Library routine AB01ND. +C On exit, the leading N-by-M part of this array contains +C the transformed matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C NBLK (input) INTEGER array, dimension (N) +C The leading INDCON elements of this array must contain the +C orders of the diagonal blocks in the orthogonal canonical +C form of A, as returned by SLICOT Library routine AB01ND. +C The values of these elements must satisfy the following +C conditions: +C NBLK(1) >= NBLK(2) >= ... >= NBLK(INDCON), +C NBLK(1) + NBLK(2) + ... + NBLK(INDCON) = N. +C +C WR (input) DOUBLE PRECISION array, dimension (N) +C WI (input) DOUBLE PRECISION array, dimension (N) +C These arrays must contain the real and imaginary parts, +C respectively, of the desired poles of the closed-loop +C system, i.e., the eigenvalues of A - B*G. The poles can be +C unordered, except that complex conjugate pairs of poles +C must appear consecutively. +C The elements of WI for complex eigenvalues are modified +C internally, but restored on exit. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, the leading N-by-N part of this array must +C contain the orthogonal matrix Z generated by SLICOT +C Library routine AB01ND in the reduction of ( A, B ) to +C orthogonal canonical form. +C On exit, the leading N-by-N part of this array contains +C the orthogonal transformation matrix which reduces A - B*G +C to real Schur form. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= max(1,N). +C +C Y (input) DOUBLE PRECISION array, dimension (M*N) +C Y contains elements which are used as free parameters +C in the eigenstructure design. The values of these +C parameters are often set by an external optimization +C procedure. +C +C COUNT (output) INTEGER +C The actual number of elements in Y used as free +C eigenvector and feedback matrix elements in the +C eigenstructure design. +C +C G (output) DOUBLE PRECISION array, dimension (LDG,N) +C The leading M-by-N part of this array contains the +C feedback matrix which assigns the desired eigenstructure +C of A - B*G. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= max(1,M). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(M*N,M*M+2*N+4*M+1). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the pair ( A, B ) is not controllable or the free +C parameters are not set appropriately. +C +C METHOD +C +C The routine implements the method proposed in [1], [2]. +C +C REFERENCES +C +C [1] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and +C Postlethwaite, I. +C Optimal pole assignment design of linear multi-input systems. +C Report 96-11, Department of Engineering, Leicester University, +C 1996. +C +C [2] Petkov, P.Hr., Christov, N.D. and Konstantinov, M.M. +C A computational algorithm for pole assignment of linear multi +C input systems. IEEE Trans. Automatic Control, vol. AC-31, +C pp. 1044-1047, 1986. +C +C NUMERICAL ASPECTS +C +C The method implemented is backward stable. +C +C FURTHER COMMENTS +C +C The eigenvalues of the real Schur form matrix As, returned in the +C array A, are very close to the desired eigenvalues WR+WI*i. +C However, the eigenvalues of the closed-loop matrix A - B*G, +C computed by the QR algorithm using the matrices A and B, given on +C entry, may be far from WR+WI*i, although the relative error +C norm( Z'*(A - B*G)*Z - As )/norm( As ) +C is close to machine accuracy. This may happen when the eigenvalue +C problem for the matrix A - B*G is ill-conditioned. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, Technical University of Sofia, Oct. 1998. +C V. Sima, Katholieke Universiteit Leuven, Jan. 1999, SLICOT Library +C version. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2005. +C +C KEYWORDS +C +C Closed loop spectrum, closed loop systems, eigenvalue assignment, +C orthogonal canonical form, orthogonal transformation, pole +C placement, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C +C .. Scalar Arguments .. + INTEGER COUNT, INDCON, INFO, LDA, LDB, LDG, LDWORK, + $ LDZ, M, N + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ), NBLK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), + $ G( LDG, * ), WI( * ), WR( * ), Y( * ), + $ Z( LDZ, * ) +C .. +C .. Local Scalars .. + LOGICAL COMPLX + INTEGER I, IA, INDCN1, INDCN2, INDCRT, IP, IRMX, IWRK, + $ K, KK, KMR, L, LP1, M1, MAXWRK, MI, MP1, MR, + $ MR1, NBLKCR, NC, NI, NJ, NP1, NR, NR1, RANK + DOUBLE PRECISION P, Q, R, S, SVLMAX, TOLDEF +C .. +C .. Local Arrays .. + DOUBLE PRECISION SVAL( 3 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLAPY2 + EXTERNAL DASUM, DLAMCH, DLANGE, DLAPY2 +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLARF, + $ DLARFG, DLARTG, DLASET, DROT, DSCAL, MB02QD, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input arguments. +C + INFO = 0 + NR = 0 + IWRK = MAX( M*N, M*M + 2*N + 4*M + 1 ) + DO 10 I = 1, MIN( INDCON, N ) + NR = NR + NBLK( I ) + IF( I.GT.1 ) THEN + IF( NBLK( I-1 ).LT.NBLK( I ) ) + $ INFO = -8 + END IF + 10 CONTINUE + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( INDCON.LT.0 .OR. INDCON.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( NR.NE.N ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDG.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDWORK.LT.IWRK ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB01DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( M, N, INDCON ).EQ.0 ) THEN + COUNT = 0 + DWORK( 1 ) = ONE + RETURN + END IF +C + MAXWRK = IWRK + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance, based on machine precision. +C + TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) + END IF +C + IRMX = 2*N + 1 + IWRK = IRMX + M*M + M1 = NBLK( 1 ) + COUNT = 1 + INDCRT = INDCON + NBLKCR = NBLK( INDCRT ) +C +C Compute the Frobenius norm of [ B A ] (used for rank estimation), +C taking into account the structure. +C + NR = M1 + NC = 1 + SVLMAX = DLANGE( 'Frobenius', M1, M, B, LDB, DWORK ) +C + DO 20 I = 1, INDCRT - 1 + NR = NR + NBLK( I+1 ) + SVLMAX = DLAPY2( SVLMAX, + $ DLANGE( 'Frobenius', NR, NBLK( I ), + $ A( 1, NC ), LDA, DWORK ) ) + NC = NC + NBLK( I ) + 20 CONTINUE +C + SVLMAX = DLAPY2( SVLMAX, + $ DLANGE( 'Frobenius', N, NBLKCR, A( 1, NC ), LDA, + $ DWORK ) ) + L = 1 + MR = NBLKCR + NR = N - MR + 1 + 30 CONTINUE +C WHILE( INDCRT.GT.1 )LOOP + IF( INDCRT.GT.1 ) THEN +C +C Assign next eigenvalue/eigenvector. +C + LP1 = L + M1 + INDCN1 = INDCRT - 1 + MR1 = NBLK( INDCN1 ) + NR1 = NR - MR1 + COMPLX = WI(L).NE.ZERO + CALL DCOPY( MR, Y( COUNT ), 1, DWORK( NR ), 1 ) + COUNT = COUNT + MR + NC = 1 + IF( COMPLX ) THEN + CALL DCOPY( MR, Y( COUNT ), 1, DWORK( N+NR ), 1 ) + COUNT = COUNT + MR + WI( L+1 ) = WI( L )*WI( L+1 ) + NC = 2 + END IF +C +C Compute and transform eiegenvector. +C + DO 50 IP = 1, INDCRT + IF( IP.NE.INDCRT ) THEN + CALL DLACPY( 'Full', MR, MR1, A( NR, NR1 ), LDA, + $ DWORK( IRMX ), M ) + IF( IP.EQ.1 ) THEN + MP1 = MR + NP1 = NR + MP1 + ELSE + MP1 = MR + 1 + NP1 = NR + MP1 + S = DASUM( MP1, DWORK( NR ), 1 ) + IF( COMPLX ) S = S + DASUM( MP1, DWORK( N+NR ), 1 ) + IF( S.NE.ZERO ) THEN +C +C Scale eigenvector elements. +C + CALL DSCAL( MP1, ONE/S, DWORK( NR ), 1 ) + IF( COMPLX ) THEN + CALL DSCAL( MP1, ONE/S, DWORK( N+NR ), 1 ) + IF( NP1.LE.N ) + $ DWORK( N+NP1 ) = DWORK( N+NP1 ) / S + END IF + END IF + END IF +C +C Compute the right-hand side of the eigenvector equations. +C + CALL DCOPY( MR, DWORK( NR ), 1, DWORK( NR1 ), 1 ) + CALL DSCAL( MR, WR( L ), DWORK( NR1 ), 1 ) + CALL DGEMV( 'No transpose', MR, MP1, -ONE, A( NR, NR ), + $ LDA, DWORK( NR ), 1, ONE, DWORK( NR1 ), 1 ) + IF( COMPLX ) THEN + CALL DAXPY( MR, WI( L+1 ), DWORK( N+NR ), 1, + $ DWORK( NR1 ), 1 ) + CALL DCOPY( MR, DWORK( NR ), 1, DWORK( N+NR1 ), 1 ) + CALL DAXPY( MR, WR( L+1 ), DWORK( N+NR ), 1, + $ DWORK( N+NR1 ), 1 ) + CALL DGEMV( 'No transpose', MR, MP1, -ONE, + $ A( NR, NR ), LDA, DWORK( N+NR ), 1, ONE, + $ DWORK( N+NR1 ), 1 ) + IF( NP1.LE.N ) + $ CALL DAXPY( MR, -DWORK( N+NP1 ), A( NR, NP1 ), 1, + $ DWORK( N+NR1 ), 1 ) + END IF +C +C Solve linear equations for eigenvector elements. +C + CALL MB02QD( 'FreeElements', 'NoPermuting', MR, MR1, NC, + $ TOLDEF, SVLMAX, DWORK( IRMX ), M, + $ DWORK( NR1 ), N, Y( COUNT ), IWORK, RANK, + $ SVAL, DWORK( IWRK ), LDWORK-IWRK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) + IF( RANK.LT.MR ) GO TO 80 +C + COUNT = COUNT + ( MR1 - MR )*NC + NJ = NR1 + ELSE + NJ = NR + END IF + NI = NR + MR - 1 + IF( IP.EQ.1 ) THEN + KMR = MR - 1 + ELSE + KMR = MR + IF( IP.EQ.2 ) THEN + NI = NI + NBLKCR + ELSE + NI = NI + NBLK( INDCRT-IP+2 ) + 1 + IF( COMPLX ) NI = MIN( NI+1, N ) + END IF + END IF +C + DO 40 KK = 1, KMR + K = NR + MR - KK + IF( IP.EQ.1 ) K = N - KK + CALL DLARTG( DWORK( K ), DWORK( K+1 ), P, Q, R ) + DWORK( K ) = R + DWORK( K+1 ) = ZERO +C +C Transform A. +C + CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), LDA, + $ P, Q ) + CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) +C + IF( K.LT.LP1 ) THEN +C +C Transform B. +C + CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, P, Q ) + END IF +C +C Accumulate transformations. +C + CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) +C + IF( COMPLX ) THEN + CALL DROT( 1, DWORK( N+K ), 1, DWORK( N+K+1 ), 1, P, + $ Q ) + K = K + 1 + IF( K.LT.N ) THEN + CALL DLARTG( DWORK( N+K ), DWORK( N+K+1 ), P, Q, + $ R ) + DWORK( N+K ) = R + DWORK( N+K+1 ) = ZERO +C +C Transform A. +C + CALL DROT( N-NJ+1, A( K, NJ ), LDA, A( K+1, NJ ), + $ LDA, P, Q ) + CALL DROT( NI, A( 1, K ), 1, A( 1, K+1 ), 1, P, Q ) +C + IF( K.LE.LP1 ) THEN +C +C Transform B. +C + CALL DROT( M, B( K, 1 ), LDB, B( K+1, 1 ), LDB, + $ P, Q ) + END IF +C +C Accumulate transformations. +C + CALL DROT( N, Z( 1, K ), 1, Z( 1, K+1 ), 1, P, Q ) +C + END IF + END IF + 40 CONTINUE +C + IF( IP.NE.INDCRT ) THEN + MR = MR1 + NR = NR1 + IF( IP.NE.INDCN1 ) THEN + INDCN2 = INDCRT - IP - 1 + MR1 = NBLK( INDCN2 ) + NR1 = NR1 - MR1 + END IF + END IF + 50 CONTINUE +C + IF( .NOT.COMPLX ) THEN +C +C Find one column of G. +C + CALL DLACPY( 'Full', M1, M, B( L+1, 1 ), LDB, DWORK( IRMX ), + $ M ) + CALL DCOPY( M1, A( L+1, L ), 1, G( 1, L ), 1 ) + ELSE +C +C Find two columns of G. +C + IF( LP1.LT.N ) THEN + LP1 = LP1 + 1 + K = L + 2 + ELSE + K = L + 1 + END IF + CALL DLACPY( 'Full', M1, M, B( K, 1 ), LDB, DWORK( IRMX ), + $ M ) + CALL DLACPY( 'Full', M1, 2, A( K, L ), LDA, G( 1, L ), LDG ) + IF( K.EQ.L+1 ) THEN + G( 1, L ) = G( 1, L ) - + $ ( DWORK( N+L+1 ) / DWORK( L ) )*WI( L+1 ) + G( 1, L+1 ) = G( 1, L+1 ) - WR(L+1) + + $ ( DWORK( N+L ) / DWORK( L ) )*WI( L+1 ) + END IF + END IF +C + CALL MB02QD( 'FreeElements', 'NoPermuting', M1, M, NC, TOLDEF, + $ SVLMAX, DWORK( IRMX ), M, G( 1, L ), LDG, + $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) + IF( RANK.LT.M1 ) GO TO 80 +C + COUNT = COUNT + ( M - M1 )*NC + CALL DGEMM( 'No transpose', 'No transpose', LP1, NC, M, -ONE, + $ B, LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) + L = L + 1 + NBLKCR = NBLKCR - 1 + IF( NBLKCR.EQ.0 ) THEN + INDCRT = INDCRT - 1 + NBLKCR = NBLK( INDCRT ) + END IF + IF( COMPLX ) THEN + WI( L ) = -WI( L-1 ) + L = L + 1 + NBLKCR = NBLKCR - 1 + IF( NBLKCR.EQ.0 ) THEN + INDCRT = INDCRT - 1 + IF( INDCRT.GT.0 ) NBLKCR = NBLK( INDCRT ) + END IF + END IF + MR = NBLKCR + NR = N - MR + 1 + GO TO 30 + END IF +C END WHILE 30 +C + IF( L.LE.N ) THEN +C +C Find the remaining columns of G. +C +C QR decomposition of the free eigenvectors. +C + DO 60 I = 1, MR - 1 + IA = L + I - 1 + MI = MR - I + 1 + CALL DCOPY( MI, Y( COUNT ), 1, DWORK( 1 ), 1 ) + COUNT = COUNT + MI + CALL DLARFG( MI, DWORK( 1 ), DWORK( 2 ), 1, R ) + DWORK( 1 ) = ONE +C +C Transform A. +C + CALL DLARF( 'Left', MI, MR, DWORK( 1 ), 1, R, A( IA, L ), + $ LDA, DWORK( N+1 ) ) + CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, A( 1, IA ), + $ LDA, DWORK( N+1 ) ) +C +C Transform B. +C + CALL DLARF( 'Left', MI, M, DWORK( 1 ), 1, R, B( IA, 1 ), + $ LDB, DWORK( N+1 ) ) +C +C Accumulate transformations. +C + CALL DLARF( 'Right', N, MI, DWORK( 1 ), 1, R, Z( 1, IA ), + $ LDZ, DWORK( N+1 ) ) + 60 CONTINUE +C + I = 0 +C REPEAT + 70 CONTINUE + I = I + 1 + IA = L + I - 1 + IF( WI( IA ).EQ.ZERO ) THEN + CALL DCOPY( MR, A( IA, L ), LDA, G( I, L ), LDG ) + CALL DAXPY( MR-I, -ONE, Y( COUNT ), 1, G( I, L+I ), LDG ) + COUNT = COUNT + MR - I + G( I, IA ) = G( I, IA ) - WR( IA ) + ELSE + CALL DLACPY( 'Full', 2, MR, A( IA, L ), LDA, G( I, L ), + $ LDG ) + CALL DAXPY( MR-I-1, -ONE, Y( COUNT ), 2, G( I, L+I+1 ), + $ LDG ) + CALL DAXPY( MR-I-1, -ONE, Y( COUNT+1 ), 2, + $ G( I+1, L+I+1 ), LDG ) + COUNT = COUNT + 2*( MR - I - 1 ) + G( I, IA ) = G(I, IA ) - WR( IA ) + G( I, IA+1 ) = G(I, IA+1 ) - WI( IA ) + G( I+1, IA ) = G(I+1, IA ) - WI( IA+1 ) + G( I+1, IA+1 ) = G(I+1, IA+1 ) - WR( IA+1 ) + I = I + 1 + END IF + IF( I.LT.MR ) GO TO 70 +C UNTIL I.GE.MR +C + CALL DLACPY( 'Full', MR, M, B( L, 1 ), LDB, DWORK( IRMX ), M ) + CALL MB02QD( 'FreeElements', 'NoPermuting', MR, M, MR, TOLDEF, + $ SVLMAX, DWORK( IRMX ), M, G( 1, L ), LDG, + $ Y( COUNT ), IWORK, RANK, SVAL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO ) + MAXWRK = MAX( MAXWRK, INT( DWORK( IWRK ) ) + IWRK - 1 ) + IF( RANK.LT.MR ) GO TO 80 +C + COUNT = COUNT + ( M - MR )*MR + CALL DGEMM( 'No transpose', 'No transpose', N, MR, M, -ONE, B, + $ LDB, G( 1, L ), LDG, ONE, A( 1, L ), LDA ) + END IF +C +C Transform G: +C G := G * Z'. +C + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, G, LDG, + $ Z, LDZ, ZERO, DWORK( 1 ), M ) + CALL DLACPY( 'Full', M, N, DWORK( 1 ), M, G, LDG ) + COUNT = COUNT - 1 +C + IF( N.GT.2) THEN +C +C Set the elements of A below the Hessenberg part to zero. +C + CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) + END IF + DWORK( 1 ) = MAXWRK + RETURN +C +C Exit with INFO = 1 if the pair ( A, B ) is not controllable or +C the free parameters are not set appropriately. +C + 80 INFO = 1 + RETURN +C *** Last line of SB01DD *** + END diff --git a/mex/sources/libslicot/SB01FY.f b/mex/sources/libslicot/SB01FY.f new file mode 100644 index 000000000..20a716ba1 --- /dev/null +++ b/mex/sources/libslicot/SB01FY.f @@ -0,0 +1,315 @@ + SUBROUTINE SB01FY( DISCR, N, M, A, LDA, B, LDB, F, LDF, V, LDV, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the inner denominator of a right-coprime factorization +C of a system of order N, where N is either 1 or 2. Specifically, +C given the N-by-N unstable system state matrix A and the N-by-M +C system input matrix B, an M-by-N state-feedback matrix F and +C an M-by-M matrix V are constructed, such that the system +C (A + B*F, B*V, F, V) is inner. +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the type of system as follows: +C = .FALSE.: continuous-time system; +C = .TRUE. : discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and also the number of rows of +C the matrix B and the number of columns of the matrix F. +C N is either 1 or 2. +C +C M (input) INTEGER +C The number of columns of the matrices B and V, and also +C the number of rows of the matrix F. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A whose eigenvalues must have positive +C real parts if DISCR = .FALSE. or moduli greater than unity +C if DISCR = .TRUE.. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= N. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= N. +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the state- +C feedback matrix F which assigns one eigenvalue (if N = 1) +C or two eigenvalues (if N = 2) of the matrix A + B*F in +C symmetric positions with respect to the imaginary axis +C (if DISCR = .FALSE.) or the unit circle (if +C DISCR = .TRUE.). +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C V (output) DOUBLE PRECISION array, dimension (LDV,M) +C The leading M-by-M upper triangular part of this array +C contains the input/output matrix V of the resulting inner +C system in upper triangular form. +C If DISCR = .FALSE., the resulting V is an identity matrix. +C +C LDV INTEGER +C The leading dimension of array V. LDF >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if uncontrollability of the pair (A,B) is detected; +C = 2: if A is stable or at the stability limit; +C = 3: if N = 2 and A has a pair of real eigenvalues. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine RCFID2. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Feb. 1999, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D0, TWO = 2.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR + INTEGER INFO, LDA, LDB, LDF, LDV, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), F(LDF,*), V(LDV,*) +C .. Local Scalars .. + INTEGER I + DOUBLE PRECISION CS, R11, R12, R22, SCALE, SN, TEMP +C .. Local Arrays .. + DOUBLE PRECISION AT(2,2), DUMMY(2,2), U(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAPY2, DLAPY3 + EXTERNAL DLAPY2, DLAPY3 +C .. External Subroutines .. + EXTERNAL DLARFG, DLASET, DLATZM, DROTG, DTRTRI, MA02AD, + $ MB04OX, SB03OY +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C +C For efficiency reasons, the parameters are not checked. +C + INFO = 0 +C +C Compute an N-by-N upper triangular R such that R'*R = B*B' and +C find an upper triangular matrix U in the equation +C +C A'*U'*U + U'*U*A = R'*R if DISCR = .FALSE. or +C A'*U'*U*A - U'*U = R'*R if DISCR = .TRUE. . +C + CALL MA02AD( 'Full', N, M, B, LDB, F, LDF ) +C + IF( N.EQ.1 ) THEN +C +C The N = 1 case. +C + IF( M.GT.1 ) + $ CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) + R11 = ABS( F(1,1) ) +C +C Make sure A is unstable or divergent and find U. +C + IF( DISCR ) THEN + TEMP = ABS( A(1,1) ) + IF( TEMP.LE.ONE ) THEN + INFO = 2 + RETURN + ELSE + TEMP = R11 / SQRT( ( TEMP - ONE )*( TEMP + ONE ) ) + END IF + ELSE + IF( A(1,1).LE.ZERO ) THEN + INFO = 2 + RETURN + ELSE + TEMP = R11 / SQRT( ABS( TWO*A(1,1) ) ) + END IF + END IF + U(1,1) = TEMP + SCALE = ONE + ELSE +C +C The N = 2 case. +C + IF( M.GT.1 ) THEN + CALL DLARFG( M, F(1,1), F(2,1), 1, TEMP ) + CALL DLATZM( 'Left', M, N-1, F(2,1), 1, TEMP, F(1,2), + $ F(2,2), LDF, V ) + END IF + R11 = F(1,1) + R12 = F(1,2) + IF( M.GT.2 ) + $ CALL DLARFG( M-1, F(2,2), F(3,2), 1, TEMP ) + IF( M.EQ.1 ) THEN + R22 = ZERO + ELSE + R22 = F(2,2) + END IF + AT(1,1) = A(1,1) + AT(1,2) = A(2,1) + AT(2,1) = A(1,2) + AT(2,2) = A(2,2) + U(1,1) = R11 + U(1,2) = R12 + U(2,2) = R22 + CALL SB03OY( DISCR, .FALSE., -1, AT, 2, U, 2, DUMMY, 2, + $ SCALE, INFO ) + IF( INFO.NE.0 ) THEN + IF( INFO.NE.4 ) THEN + INFO = 2 + ELSE + INFO = 3 + END IF + RETURN + END IF + END IF +C +C Check the controllability of the pair (A,B). +C +C Warning. Only an exact controllability check is performed. +C If the pair (A,B) is nearly uncontrollable, then +C the computed results may be inaccurate. +C + DO 10 I = 1, N + IF( U(I,I).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF + 10 CONTINUE +C +C Set V = I. +C + CALL DLASET( 'Upper', M, M, ZERO, ONE, V, LDV ) +C + IF( DISCR ) THEN +C +C Compute an upper triangular matrix V such that +C -1 +C V*V' = (I+B'*inv(U'*U)*B) . +C +C First compute F = B'*inv(U) and the Cholesky factorization +C of I + F*F'. +C + DO 20 I = 1, M + F(I,1) = B(1,I)/U(1,1)*SCALE + 20 CONTINUE + IF( N.EQ.2 ) THEN + DO 30 I = 1, M + F(I,2) = ( B(2,I) - F(I,1)*U(1,2) )/U(2,2)*SCALE + 30 CONTINUE + CALL MB04OX( M, V, LDV, F(1,2), 1 ) + END IF + CALL MB04OX( M, V, LDV, F(1,1), 1 ) + CALL DTRTRI( 'Upper', 'NonUnit', M, V, LDV, INFO ) + END IF +C +C Compute the feedback matrix F as: +C +C 1) If DISCR = .FALSE. +C +C F = -B'*inv(U'*U); +C +C 2) If DISCR = .TRUE. +C -1 +C F = -B'*(U'*U+B*B') *A. +C + IF( N.EQ.1 ) THEN + IF( DISCR ) THEN + TEMP = -A(1,1) + R11 = DLAPY2( U(1,1), R11 ) + DO 40 I = 1, M + F(I,1) = ( ( B(1,I)/R11 )/R11 )*TEMP + 40 CONTINUE + ELSE + R11 = U(1,1) + DO 50 I = 1, M + F(I,1) = -( ( B(1,I)/R11 )/R11 ) + 50 CONTINUE + END IF + ELSE +C +C Set R = U if DISCR = .FALSE. or compute the Cholesky +C factorization of R'*R = U'*U+B*B' if DISCR = .TRUE.. +C + IF( DISCR ) THEN + TEMP = U(1,1) + CALL DROTG( R11, TEMP, CS, SN ) + TEMP = -SN*R12 + CS*U(1,2) + R12 = CS*R12 + SN*U(1,2) + R22 = DLAPY3( R22, TEMP, U(2,2) ) + ELSE + R11 = U(1,1) + R12 = U(1,2) + R22 = U(2,2) + END IF +C +C Compute F = -B'*inv(R'*R). +C + DO 60 I = 1, M + F(I,1) = -B(1,I)/R11 + F(I,2) = -( B(2,I) + F(I,1)*R12 )/R22 + F(I,2) = F(I,2)/R22 + F(I,1) = ( F(I,1) - F(I,2)*R12 )/R11 + 60 CONTINUE + IF( DISCR ) THEN +C +C Compute F <-- F*A. +C + DO 70 I = 1, M + TEMP = F(I,1)*A(1,1) + F(I,2)*A(2,1) + F(I,2) = F(I,1)*A(1,2) + F(I,2)*A(2,2) + F(I,1) = TEMP + 70 CONTINUE + END IF + END IF +C + RETURN +C *** Last line of SB01FY *** + END diff --git a/mex/sources/libslicot/SB01MD.f b/mex/sources/libslicot/SB01MD.f new file mode 100644 index 000000000..cc6abc4d8 --- /dev/null +++ b/mex/sources/libslicot/SB01MD.f @@ -0,0 +1,397 @@ + SUBROUTINE SB01MD( NCONT, N, A, LDA, B, WR, WI, Z, LDZ, G, DWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To determine the one-dimensional state feedback matrix G of the +C linear time-invariant single-input system +C +C dX/dt = A * X + B * U, +C +C where A is an NCONT-by-NCONT matrix and B is an NCONT element +C vector such that the closed-loop system +C +C dX/dt = (A - B * G) * X +C +C has desired poles. The system must be preliminarily reduced +C to orthogonal canonical form using the SLICOT Library routine +C AB01MD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NCONT (input) INTEGER +C The order of the matrix A as produced by SLICOT Library +C routine AB01MD. NCONT >= 0. +C +C N (input) INTEGER +C The order of the matrix Z. N >= NCONT. +C +C A (input/output) DOUBLE PRECISION array, dimension +C (LDA,NCONT) +C On entry, the leading NCONT-by-NCONT part of this array +C must contain the canonical form of the state dynamics +C matrix A as produced by SLICOT Library routine AB01MD. +C On exit, the leading NCONT-by-NCONT part of this array +C contains the upper quasi-triangular form S of the closed- +C loop system matrix (A - B * G), that is triangular except +C for possible 2-by-2 diagonal blocks. +C (To reconstruct the closed-loop system matrix see +C FURTHER COMMENTS below.) +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,NCONT). +C +C B (input/output) DOUBLE PRECISION array, dimension (NCONT) +C On entry, this array must contain the canonical form of +C the input/state vector B as produced by SLICOT Library +C routine AB01MD. +C On exit, this array contains the transformed vector Z * B +C of the closed-loop system. +C +C WR (input) DOUBLE PRECISION array, dimension (NCONT) +C WI (input) DOUBLE PRECISION array, dimension (NCONT) +C These arrays must contain the real and imaginary parts, +C respectively, of the desired poles of the closed-loop +C system. The poles can be unordered, except that complex +C conjugate pairs of poles must appear consecutively. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, the leading N-by-N part of this array must +C contain the orthogonal transformation matrix as produced +C by SLICOT Library routine AB01MD, which reduces the system +C to canonical form. +C On exit, the leading NCONT-by-NCONT part of this array +C contains the orthogonal matrix Z which reduces the closed- +C loop system matrix (A - B * G) to upper quasi-triangular +C form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,N). +C +C G (output) DOUBLE PRECISION array, dimension (NCONT) +C This array contains the one-dimensional state feedback +C matrix G of the original system. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*NCONT) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The method is based on the orthogonal reduction of the closed-loop +C system matrix (A - B * G) to upper quasi-triangular form S whose +C 1-by-1 and 2-by-2 diagonal blocks correspond to the desired poles. +C That is, S = Z'*(A - B * G)*Z, where Z is an orthogonal matrix. +C +C REFERENCES +C +C [1] Petkov, P. Hr. +C A Computational Algorithm for Pole Assignment of Linear +C Single Input Systems. +C Internal Report 81/2, Control Systems Research Group, School +C of Electronic Engineering and Computer Science, Kingston +C Polytechnic, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(NCONT ) operations and is backward +C stable. +C +C FURTHER COMMENTS +C +C If required, the closed-loop system matrix (A - B * G) can be +C formed from the matrix product Z * S * Z' (where S and Z are the +C matrices output in arrays A and Z respectively). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB01AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, May 1981. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Closed loop spectrum, closed loop systems, eigenvalue assignment, +C orthogonal canonical form, orthogonal transformation, pole +C placement, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDZ, N, NCONT +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), DWORK(*), G(*), WI(*), WR(*), + $ Z(LDZ,*) +C .. Local Scalars .. + LOGICAL COMPL + INTEGER I, IM1, K, L, LL, LP1, NCONT2, NI, NJ, NL + DOUBLE PRECISION B1, P, Q, R, S, T +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DLARTG, DLASET, DROT, + $ DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NCONT.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.NCONT ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, NCONT ) ) THEN + INFO = -4 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'SB01MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( NCONT.EQ.0 .OR. N.EQ.0 ) + $ RETURN +C +C Return if the system is not complete controllable. +C + IF ( B(1).EQ.ZERO ) + $ RETURN +C + IF ( NCONT.EQ.1 ) THEN +C +C 1-by-1 case. +C + P = A(1,1) - WR(1) + A(1,1) = WR(1) + G(1) = P/B(1) + Z(1,1) = ONE + RETURN + END IF +C +C General case. Save the contents of WI in DWORK. +C + NCONT2 = 2*NCONT + CALL DCOPY( NCONT, WI, 1, DWORK(NCONT2+1), 1 ) +C + B1 = B(1) + B(1) = ONE + L = 0 + LL = 0 + 20 CONTINUE + L = L + 1 + LL = LL + 1 + COMPL = DWORK(NCONT2+L).NE.ZERO + IF ( L.NE.NCONT ) THEN + LP1 = L + 1 + NL = NCONT - L + IF ( LL.NE.2 ) THEN + IF ( COMPL ) THEN +C +C Compute complex eigenvector. +C + DWORK(NCONT) = ONE + DWORK(NCONT2) = ONE + P = WR(L) + T = DWORK(NCONT2+L) + Q = T*DWORK(NCONT2+LP1) + DWORK(NCONT2+L) = ONE + DWORK(NCONT2+LP1) = Q +C + DO 40 I = NCONT, LP1, -1 + IM1 = I - 1 + DWORK(IM1) = ( P*DWORK(I) + Q*DWORK(NCONT+I) - + $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) + $ /A(I,IM1) + DWORK(NCONT+IM1) = ( P*DWORK(NCONT+I) + DWORK(I) - + $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(NCONT+I), 1 ) ) + $ /A(I,IM1) + 40 CONTINUE +C + ELSE +C +C Compute real eigenvector. +C + DWORK(NCONT) = ONE + P = WR(L) +C + DO 60 I = NCONT, LP1, -1 + IM1 = I - 1 + DWORK(IM1) = ( P*DWORK(I) - + $ DDOT( NCONT-IM1, A(I,I), LDA, DWORK(I), 1 ) ) + $ /A(I,IM1) + 60 CONTINUE +C + END IF + END IF +C +C Transform eigenvector. +C + DO 80 K = NCONT - 1, L, -1 + IF ( LL.NE.2 ) THEN + R = DWORK(K) + S = DWORK(K+1) + ELSE + R = DWORK(NCONT+K) + S = DWORK(NCONT+K+1) + END IF + CALL DLARTG( R, S, P, Q, T ) + DWORK(K) = T + IF ( LL.NE.2 ) THEN + NJ = MAX( K-1, L ) + ELSE + DWORK(NCONT+K) = T + NJ = L - 1 + END IF +C +C Transform A. +C + CALL DROT( NCONT-NJ+1, A(K,NJ), LDA, A(K+1,NJ), LDA, P, Q ) +C + IF ( COMPL .AND. LL.EQ.1 ) THEN + NI = NCONT + ELSE + NI = MIN( K+2, NCONT ) + END IF + CALL DROT( NI, A(1,K), 1, A(1,K+1), 1, P, Q ) +C + IF ( K.EQ.L ) THEN +C +C Transform B. +C + T = B(K) + B(K) = P*T + B(K+1) = -Q*T + END IF +C +C Accumulate transformations. +C + CALL DROT( NCONT, Z(1,K), 1, Z(1,K+1), 1, P, Q ) +C + IF ( COMPL .AND. LL.NE.2 ) THEN + T = DWORK(NCONT+K) + DWORK(NCONT+K) = P*T + Q*DWORK(NCONT+K+1) + DWORK(NCONT+K+1) = P*DWORK(NCONT+K+1) - Q*T + END IF + 80 CONTINUE +C + END IF +C + IF ( .NOT.COMPL ) THEN +C +C Find one element of G. +C + K = L + R = B(L) + IF ( L.NE.NCONT ) THEN + IF ( ABS( B(LP1) ).GT.ABS( B(L) ) ) THEN + K = LP1 + R = B(LP1) + END IF + END IF + P = A(K,L) + IF ( K.EQ.L ) P = P - WR(L) + P = P/R +C + CALL DAXPY( LP1, -P, B, 1, A(1,L), 1 ) +C + G(L) = P/B1 + IF ( L.NE.NCONT ) THEN + LL = 0 + GO TO 20 + END IF + ELSE IF ( LL.EQ.1 ) THEN + GO TO 20 + ELSE +C +C Find two elements of G. +C + K = L + R = B(L) + IF ( L.NE.NCONT ) THEN + IF ( ABS( B(LP1)).GT.ABS( B(L) ) ) THEN + K = LP1 + R = B(LP1) + END IF + END IF + P = A(K,L-1) + Q = A(K,L) + IF ( K.EQ.L ) THEN + P = P - ( DWORK(NCONT+L)/DWORK(L-1) )*DWORK(NCONT2+L) + Q = Q - WR(L) + + $ ( DWORK(NCONT+L-1)/DWORK(L-1) )*DWORK(NCONT2+L) + END IF + P = P/R + Q = Q/R +C + CALL DAXPY( LP1, -P, B, 1, A(1,L-1), 1 ) + CALL DAXPY( LP1, -Q, B, 1, A(1,L), 1 ) +C + G(L-1) = P/B1 + G(L) = Q/B1 + IF ( L.NE.NCONT ) THEN + LL = 0 + GO TO 20 + END IF + END IF +C +C Transform G. +C + CALL DGEMV( 'No transpose', NCONT, NCONT, ONE, Z, LDZ, G, 1, + $ ZERO, DWORK, 1 ) + CALL DCOPY( NCONT, DWORK, 1, G, 1 ) + CALL DSCAL( NCONT, B1, B, 1 ) +C +C Annihilate A after the first subdiagonal. +C + IF ( NCONT.GT.2 ) + $ CALL DLASET( 'Lower', NCONT-2, NCONT-2, ZERO, ZERO, A(3,1), + $ LDA ) +C + RETURN +C *** Last line of SB01MD *** + END diff --git a/mex/sources/libslicot/SB02CX.f b/mex/sources/libslicot/SB02CX.f new file mode 100644 index 000000000..d84f72178 --- /dev/null +++ b/mex/sources/libslicot/SB02CX.f @@ -0,0 +1,94 @@ + LOGICAL FUNCTION SB02CX( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the purely imaginary eigenvalues in computing the +C H-infinity norm of a system. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C REIG (input) DOUBLE PRECISION +C The real part of the current eigenvalue considered. +C +C IEIG (input) DOUBLE PRECISION +C The imaginary part of the current eigenvalue considered. +C +C METHOD +C +C The function value SB02CX is set to .TRUE. for a purely imaginary +C eigenvalue and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C P. Hr. Petkov, Technical University of Sofia, May, 1999. +C +C REVISIONS +C +C P. Hr. Petkov, Technical University of Sofia, Oct. 2000. +C +C KEYWORDS +C +C H-infinity norm, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HUNDRD + PARAMETER ( HUNDRD = 100.0D+0 ) +C .. +C .. Scalar Arguments .. + DOUBLE PRECISION IEIG, REIG +C .. +C .. Local Scalars .. + DOUBLE PRECISION EPS, TOL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. +C .. Executable Statements .. +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Set the tolerance in the determination of the purely +C imaginary eigenvalues. +C + TOL = HUNDRD*EPS + SB02CX = ABS( REIG ).LT.TOL +C + RETURN +C *** Last line of SB02CX *** + END diff --git a/mex/sources/libslicot/SB02MD.f b/mex/sources/libslicot/SB02MD.f new file mode 100644 index 000000000..4e517d346 --- /dev/null +++ b/mex/sources/libslicot/SB02MD.f @@ -0,0 +1,559 @@ + SUBROUTINE SB02MD( DICO, HINV, UPLO, SCAL, SORT, N, A, LDA, G, + $ LDG, Q, LDQ, RCOND, WR, WI, S, LDS, U, LDU, + $ IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the continuous-time algebraic Riccati +C equation +C -1 +C Q + A'*X + X*A - X*B*R B'*X = 0 (1) +C +C or the discrete-time algebraic Riccati equation +C -1 +C X = A'*X*A - A'*X*B*(R + B'*X*B) B'*X*A + Q (2) +C +C where A, B, Q and R are N-by-N, N-by-M, N-by-N and M-by-M matrices +C respectively, with Q symmetric and R symmetric nonsingular; X is +C an N-by-N symmetric matrix. +C -1 +C The matrix G = B*R B' must be provided on input, instead of B and +C R, that is, for instance, the continuous-time equation +C +C Q + A'*X + X*A - X*G*X = 0 (3) +C +C is solved, where G is an N-by-N symmetric matrix. SLICOT Library +C routine SB02MT should be used to compute G, given B and R. SB02MT +C also enables to solve Riccati equations corresponding to optimal +C problems with coupling terms. +C +C The routine also returns the computed values of the closed-loop +C spectrum of the optimal system, i.e., the stable eigenvalues +C lambda(1),...,lambda(N) of the corresponding Hamiltonian or +C symplectic matrix associated to the optimal problem. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of Riccati equation to be solved as +C follows: +C = 'C': Equation (3), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C HINV CHARACTER*1 +C If DICO = 'D', specifies which symplectic matrix is to be +C constructed, as follows: +C = 'D': The matrix H in (5) (see METHOD) is constructed; +C = 'I': The inverse of the matrix H in (5) is constructed. +C HINV is not used if DICO = 'C'. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C SCAL CHARACTER*1 +C Specifies whether or not a scaling strategy should be +C used, as follows: +C = 'G': General scaling should be used; +C = 'N': No scaling should be used. +C +C SORT CHARACTER*1 +C Specifies which eigenvalues should be obtained in the top +C of the Schur form, as follows: +C = 'S': Stable eigenvalues come first; +C = 'U': Unstable eigenvalues come first. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, Q, G and X. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, if DICO = 'D', and INFO = 0 or INFO > 1, the +C -1 +C leading N-by-N part of this array contains the matrix A . +C Otherwise, the array A is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C G (input) DOUBLE PRECISION array, dimension (LDG,N) +C The leading N-by-N upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C must contain the upper triangular part or lower triangular +C part, respectively, of the symmetric matrix G. The stricly +C lower triangular part (if UPLO = 'U') or stricly upper +C triangular part (if UPLO = 'L') is not referenced. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, the leading N-by-N upper triangular part (if +C UPLO = 'U') or lower triangular part (if UPLO = 'L') of +C this array must contain the upper triangular part or lower +C triangular part, respectively, of the symmetric matrix Q. +C The stricly lower triangular part (if UPLO = 'U') or +C stricly upper triangular part (if UPLO = 'L') is not used. +C On exit, if INFO = 0, the leading N-by-N part of this +C array contains the solution matrix X of the problem. +C +C LDQ INTEGER +C The leading dimension of array N. LDQ >= MAX(1,N). +C +C RCOND (output) DOUBLE PRECISION +C An estimate of the reciprocal of the condition number (in +C the 1-norm) of the N-th order system of algebraic +C equations from which the solution matrix X is obtained. +C +C WR (output) DOUBLE PRECISION array, dimension (2*N) +C WI (output) DOUBLE PRECISION array, dimension (2*N) +C If INFO = 0 or INFO = 5, these arrays contain the real and +C imaginary parts, respectively, of the eigenvalues of the +C 2N-by-2N matrix S, ordered as specified by SORT (except +C for the case HINV = 'D', when the order is opposite to +C that specified by SORT). The leading N elements of these +C arrays contain the closed-loop spectrum of the system +C -1 +C matrix A - B*R *B'*X, if DICO = 'C', or of the matrix +C -1 +C A - B*(R + B'*X*B) B'*X*A, if DICO = 'D'. Specifically, +C lambda(k) = WR(k) + j*WI(k), for k = 1,2,...,N. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) +C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this +C array contains the ordered real Schur form S of the +C Hamiltonian or symplectic matrix H. That is, +C +C (S S ) +C ( 11 12) +C S = ( ), +C (0 S ) +C ( 22) +C +C where S , S and S are N-by-N matrices. +C 11 12 22 +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,2*N). +C +C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) +C If INFO = 0 or INFO = 5, the leading 2N-by-2N part of this +C array contains the transformation matrix U which reduces +C the Hamiltonian or symplectic matrix H to the ordered real +C Schur form S. That is, +C +C (U U ) +C ( 11 12) +C U = ( ), +C (U U ) +C ( 21 22) +C +C where U , U , U and U are N-by-N matrices. +C 11 12 21 22 +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,2*N). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) returns the scaling factor used +C (set to 1 if SCAL = 'N'), also set if INFO = 5; +C if DICO = 'D', DWORK(3) returns the reciprocal condition +C number of the given matrix A. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(2,6*N) if DICO = 'C'; +C LDWORK >= MAX(3,6*N) if DICO = 'D'. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if matrix A is (numerically) singular in discrete- +C time case; +C = 2: if the Hamiltonian or symplectic matrix H cannot be +C reduced to real Schur form; +C = 3: if the real Schur form of the Hamiltonian or +C symplectic matrix H cannot be appropriately ordered; +C = 4: if the Hamiltonian or symplectic matrix H has less +C than N stable eigenvalues; +C = 5: if the N-th order system of linear algebraic +C equations, from which the solution matrix X would +C be obtained, is singular to working precision. +C +C METHOD +C +C The method used is the Schur vector approach proposed by Laub. +C It is assumed that [A,B] is a stabilizable pair (where for (3) B +C is any matrix such that B*B' = G with rank(B) = rank(G)), and +C [E,A] is a detectable pair, where E is any matrix such that +C E*E' = Q with rank(E) = rank(Q). Under these assumptions, any of +C the algebraic Riccati equations (1)-(3) is known to have a unique +C non-negative definite solution. See [2]. +C Now consider the 2N-by-2N Hamiltonian or symplectic matrix +C +C ( A -G ) +C H = ( ), (4) +C (-Q -A'), +C +C for continuous-time equation, and +C -1 -1 +C ( A A *G ) +C H = ( -1 -1 ), (5) +C (Q*A A' + Q*A *G) +C -1 +C for discrete-time equation, respectively, where G = B*R *B'. +C The assumptions guarantee that H in (4) has no pure imaginary +C eigenvalues, and H in (5) has no eigenvalues on the unit circle. +C If Y is an N-by-N matrix then there exists an orthogonal matrix U +C such that U'*Y*U is an upper quasi-triangular matrix. Moreover, U +C can be chosen so that the 2-by-2 and 1-by-1 diagonal blocks +C (corresponding to the complex conjugate eigenvalues and real +C eigenvalues respectively) appear in any desired order. This is the +C ordered real Schur form. Thus, we can find an orthogonal +C similarity transformation U which puts (4) or (5) in ordered real +C Schur form +C +C U'*H*U = S = (S(1,1) S(1,2)) +C ( 0 S(2,2)) +C +C where S(i,j) is an N-by-N matrix and the eigenvalues of S(1,1) +C have negative real parts in case of (4), or moduli greater than +C one in case of (5). If U is conformably partitioned into four +C N-by-N blocks +C +C U = (U(1,1) U(1,2)) +C (U(2,1) U(2,2)) +C +C with respect to the assumptions we then have +C (a) U(1,1) is invertible and X = U(2,1)*inv(U(1,1)) solves (1), +C (2), or (3) with X = X' and non-negative definite; +C (b) the eigenvalues of S(1,1) (if DICO = 'C') or S(2,2) (if +C DICO = 'D') are equal to the eigenvalues of optimal system +C (the 'closed-loop' spectrum). +C +C [A,B] is stabilizable if there exists a matrix F such that (A-BF) +C is stable. [E,A] is detectable if [A',E'] is stabilizable. +C +C REFERENCES +C +C [1] Laub, A.J. +C A Schur Method for Solving Algebraic Riccati equations. +C IEEE Trans. Auto. Contr., AC-24, pp. 913-921, 1979. +C +C [2] Wonham, W.M. +C On a matrix Riccati equation of stochastic control. +C SIAM J. Contr., 6, pp. 681-697, 1968. +C +C [3] Sima, V. +C Algorithms for Linear-Quadratic Optimization. +C Pure and Applied Mathematics: A Series of Monographs and +C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C To obtain a stabilizing solution of the algebraic Riccati +C equation for DICO = 'D', set SORT = 'U', if HINV = 'D', or set +C SORT = 'S', if HINV = 'I'. +C +C The routine can also compute the anti-stabilizing solutions of +C the algebraic Riccati equations, by specifying +C SORT = 'U' if DICO = 'D' and HINV = 'I', or DICO = 'C', or +C SORT = 'S' if DICO = 'D' and HINV = 'D'. +C +C Usually, the combinations HINV = 'D' and SORT = 'U', or HINV = 'I' +C and SORT = 'U', will be faster then the other combinations [3]. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB02AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2002. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, HINV, SCAL, SORT, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDS, LDU, LDWORK, N + DOUBLE PRECISION RCOND +C .. Array Arguments .. + LOGICAL BWORK(*) + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), + $ S(LDS,*), U(LDU,*), WR(*), WI(*) +C .. Local Scalars .. + LOGICAL DISCR, LHINV, LSCAL, LSORT, LUPLO + INTEGER I, IERR, ISCL, N2, NP1, NROT + DOUBLE PRECISION GNORM, QNORM, RCONDA, UNORM, WRKOPT +C .. External Functions .. + LOGICAL LSAME, SB02MR, SB02MS, SB02MV, SB02MW + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02MR, SB02MS, + $ SB02MV, SB02MW +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGEES, DGETRF, DGETRS, + $ DLACPY, DLASCL, DLASET, DSCAL, DSWAP, SB02MU, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + N2 = N + N + NP1 = N + 1 + DISCR = LSAME( DICO, 'D' ) + LSCAL = LSAME( SCAL, 'G' ) + LSORT = LSAME( SORT, 'S' ) + LUPLO = LSAME( UPLO, 'U' ) + IF ( DISCR ) LHINV = LSAME( HINV, 'D' ) +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( DISCR ) THEN + IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) + $ INFO = -2 + END IF + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LSCAL .AND. .NOT.LSAME( SCAL, 'N' ) ) THEN + INFO = -4 + ELSE IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN + INFO = -17 + ELSE IF( LDU.LT.MAX( 1, N2 ) ) THEN + INFO = -19 + ELSE IF( ( .NOT.DISCR .AND. LDWORK.LT.MAX( 2, 6*N ) ) .OR. + $ ( DISCR .AND. LDWORK.LT.MAX( 3, 6*N ) ) ) THEN + INFO = -22 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + RCOND = ONE + DWORK(1) = ONE + DWORK(2) = ONE + IF ( DISCR ) DWORK(3) = ONE + RETURN + END IF +C + IF ( LSCAL ) THEN +C +C Compute the norms of the matrices Q and G. +C + QNORM = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + GNORM = DLANSY( '1-norm', UPLO, N, G, LDG, DWORK ) + END IF +C +C Initialise the Hamiltonian or symplectic matrix associated with +C the problem. +C Workspace: need 1 if DICO = 'C'; +C max(2,4*N) if DICO = 'D'; +C prefer larger if DICO = 'D'. +C + CALL SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S, LDS, + $ IWORK, DWORK, LDWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF +C + WRKOPT = DWORK(1) + IF ( DISCR ) RCONDA = DWORK(2) +C + ISCL = 0 + IF ( LSCAL ) THEN +C +C Scale the Hamiltonian or symplectic matrix. +C + IF( QNORM.GT.GNORM .AND. GNORM.GT.ZERO ) THEN + CALL DLASCL( 'G', 0, 0, QNORM, GNORM, N, N, S(NP1,1), N2, + $ IERR ) + CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, S(1,NP1), N2, + $ IERR ) + ISCL = 1 + END IF + END IF +C +C Find the ordered Schur factorization of S, S = U*H*U'. +C Workspace: need 6*N; +C prefer larger. +C + IF ( .NOT.DISCR ) THEN + IF ( LSORT ) THEN + CALL DGEES( 'Vectors', 'Sorted', SB02MV, N2, S, LDS, NROT, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + ELSE + CALL DGEES( 'Vectors', 'Sorted', SB02MR, N2, S, LDS, NROT, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + END IF + ELSE + IF ( LSORT ) THEN + CALL DGEES( 'Vectors', 'Sorted', SB02MW, N2, S, LDS, NROT, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + ELSE + CALL DGEES( 'Vectors', 'Sorted', SB02MS, N2, S, LDS, NROT, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + END IF + IF ( LHINV ) THEN + CALL DSWAP( N, WR, 1, WR(NP1), 1 ) + CALL DSWAP( N, WI, 1, WI(NP1), 1 ) + END IF + END IF + IF ( INFO.GT.N2 ) THEN + INFO = 3 + ELSE IF ( INFO.GT.0 ) THEN + INFO = 2 + ELSE IF ( NROT.NE.N ) THEN + INFO = 4 + END IF + IF ( INFO.NE.0 ) + $ RETURN +C + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C +C Check if U(1,1) is singular. Use the (2,1) block of S as a +C workspace for factoring U(1,1). +C + UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) +C + CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) + CALL DGETRF( N, N, S(NP1,1), LDS, IWORK, INFO ) +C + IF ( INFO.GT.0 ) THEN +C +C Singular matrix. Set INFO and RCOND for error return. +C + INFO = 5 + RCOND = ZERO + GO TO 100 + END IF +C +C Estimate the reciprocal condition of U(1,1). +C Workspace: 6*N. +C + CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCOND, + $ DWORK, IWORK(NP1), INFO ) +C + IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN +C +C Nearly singular matrix. Set INFO for error return. +C + INFO = 5 + RETURN + END IF +C +C Transpose U(2,1) in Q and compute the solution. +C + DO 60 I = 1, N + CALL DCOPY( N, U(NP1,I), 1, Q(I,1), LDQ ) + 60 CONTINUE +C + CALL DGETRS( 'Transpose', N, N, S(NP1,1), LDS, IWORK, Q, LDQ, + $ INFO ) +C +C Set S(2,1) to zero. +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) +C +C Make sure the solution matrix X is symmetric. +C + DO 80 I = 1, N - 1 + CALL DAXPY( N-I, ONE, Q(I,I+1), LDQ, Q(I+1,I), 1 ) + CALL DSCAL( N-I, HALF, Q(I+1,I), 1 ) + CALL DCOPY( N-I, Q(I+1,I), 1, Q(I,I+1), LDQ ) + 80 CONTINUE +C + IF( LSCAL ) THEN +C +C Undo scaling for the solution matrix. +C + IF( ISCL.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, GNORM, QNORM, N, N, Q, LDQ, IERR ) + END IF +C +C Set the optimal workspace, the scaling factor, and reciprocal +C condition number (if any). +C + DWORK(1) = WRKOPT + 100 CONTINUE + IF( ISCL.EQ.1 ) THEN + DWORK(2) = QNORM / GNORM + ELSE + DWORK(2) = ONE + END IF + IF ( DISCR ) DWORK(3) = RCONDA +C + RETURN +C *** Last line of SB02MD *** + END diff --git a/mex/sources/libslicot/SB02MR.f b/mex/sources/libslicot/SB02MR.f new file mode 100644 index 000000000..f306a1b93 --- /dev/null +++ b/mex/sources/libslicot/SB02MR.f @@ -0,0 +1,75 @@ + LOGICAL FUNCTION SB02MR( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02MS.f b/mex/sources/libslicot/SB02MS.f new file mode 100644 index 000000000..1e8481eb7 --- /dev/null +++ b/mex/sources/libslicot/SB02MS.f @@ -0,0 +1,79 @@ + LOGICAL FUNCTION SB02MS( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02MT.f b/mex/sources/libslicot/SB02MT.f new file mode 100644 index 000000000..7106bd971 --- /dev/null +++ b/mex/sources/libslicot/SB02MT.f @@ -0,0 +1,581 @@ + SUBROUTINE SB02MT( JOBG, JOBL, FACT, UPLO, N, M, A, LDA, B, LDB, + $ Q, LDQ, R, LDR, L, LDL, IPIV, OUFACT, G, LDG, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the following matrices +C +C -1 +C G = B*R *B', +C +C - -1 +C A = A - B*R *L', +C +C - -1 +C Q = Q - L*R *L', +C +C where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M, +C N-by-M, and N-by-N matrices, respectively, with Q, R and G +C symmetric matrices. +C +C When R is well-conditioned with respect to inversion, standard +C algorithms for solving linear-quadratic optimization problems will +C then also solve optimization problems with coupling weighting +C matrix L. Moreover, a gain in efficiency is possible using matrix +C G in the deflating subspace algorithms (see SLICOT Library routine +C SB02OD). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBG CHARACTER*1 +C Specifies whether or not the matrix G is to be computed, +C as follows: +C = 'G': Compute G; +C = 'N': Do not compute G. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C +C FACT CHARACTER*1 +C Specifies how the matrix R is given (factored or not), as +C follows: +C = 'N': Array R contains the matrix R; +C = 'C': Array R contains the Cholesky factor of R; +C = 'U': Array R contains the symmetric indefinite UdU' or +C LdL' factorization of R. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices R and Q (if +C JOBL = 'N') is stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, Q, and G, and the number of +C rows of the matrices B and L. N >= 0. +C +C M (input) INTEGER +C The order of the matrix R, and the number of columns of +C the matrices B and L. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if JOBL = 'N', the leading N-by-N part of this +C array must contain the matrix A. +C On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N +C - -1 +C part of this array contains the matrix A = A - B*R L'. +C If JOBL = 'Z', this array is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,N) if JOBL = 'N'; +C LDA >= 1 if JOBL = 'Z'. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the matrix B. +C On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M +C -1 +C part of this array contains the matrix B*chol(R) . +C On exit, B is unchanged if OUFACT = 2 (hence also when +C FACT = 'U'). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if JOBL = 'N', the leading N-by-N upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the upper +C triangular part or lower triangular part, respectively, of +C the symmetric matrix Q. The stricly lower triangular part +C (if UPLO = 'U') or stricly upper triangular part (if +C UPLO = 'L') is not referenced. +C On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N +C upper triangular part (if UPLO = 'U') or lower triangular +C part (if UPLO = 'L') of this array contains the upper +C triangular part or lower triangular part, respectively, of +C - -1 +C the symmetric matrix Q = Q - L*R *L'. +C If JOBL = 'Z', this array is not referenced. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,N) if JOBL = 'N'; +C LDQ >= 1 if JOBL = 'Z'. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry, if FACT = 'N', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the upper +C triangular part or lower triangular part, respectively, +C of the symmetric input weighting matrix R. +C On entry, if FACT = 'C', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the Cholesky +C factor of the positive definite input weighting matrix R +C (as produced by LAPACK routine DPOTRF). +C On entry, if FACT = 'U', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the factors of +C the UdU' or LdL' factorization, respectively, of the +C symmetric indefinite input weighting matrix R (as produced +C by LAPACK routine DSYTRF). +C If FACT = 'N', the stricly lower triangular part (if UPLO +C = 'U') or stricly upper triangular part (if UPLO = 'L') of +C this array is used as workspace. +C On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the Cholesky factor of the given input weighting +C matrix. +C On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the factors of the UdU' or LdL' factorization, +C respectively, of the given input weighting matrix. +C On exit R is unchanged if FACT = 'C' or 'U'. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,M). +C +C L (input/output) DOUBLE PRECISION array, dimension (LDL,M) +C On entry, if JOBL = 'N', the leading N-by-M part of this +C array must contain the matrix L. +C On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the +C leading N-by-M part of this array contains the matrix +C -1 +C L*chol(R) . +C On exit, L is unchanged if OUFACT = 2 (hence also when +C FACT = 'U'). +C L is not referenced if JOBL = 'Z'. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N'; +C LDL >= 1 if JOBL = 'Z'. +C +C IPIV (input/output) INTEGER array, dimension (M) +C On entry, if FACT = 'U', this array must contain details +C of the interchanges performed and the block structure of +C the d factor in the UdU' or LdL' factorization of matrix R +C (as produced by LAPACK routine DSYTRF). +C On exit, if OUFACT = 2, this array contains details of +C the interchanges performed and the block structure of the +C d factor in the UdU' or LdL' factorization of matrix R, +C as produced by LAPACK routine DSYTRF. +C This array is not referenced if FACT = 'C'. +C +C OUFACT (output) INTEGER +C Information about the factorization finally used. +C OUFACT = 1: Cholesky factorization of R has been used; +C OUFACT = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L') +C factorization of R has been used. +C +C G (output) DOUBLE PRECISION array, dimension (LDG,N) +C If JOBG = 'G', and INFO = 0, the leading N-by-N upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array contains the upper +C triangular part (if UPLO = 'U') or lower triangular part +C -1 +C (if UPLO = 'L'), respectively, of the matrix G = B*R B'. +C If JOBG = 'N', this array is not referenced. +C +C LDG INTEGER +C The leading dimension of array G. +C LDG >= MAX(1,N) if JOBG = 'G', +C LDG >= 1 if JOBG = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; if FACT = 'N', DWORK(2) contains the reciprocal +C condition number of the given matrix R. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1 if FACT = 'C'; +C LDWORK >= MAX(2,3*M,N*M) if FACT = 'N'; +C LDWORK >= MAX(1,N*M) if FACT = 'U'. +C For optimum performance LDWORK should be larger than 3*M, +C if FACT = 'N'. +C The N*M workspace is not needed for FACT = 'N', if matrix +C R is positive definite. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the i-th element (1 <= i <= M) of the d factor is +C exactly zero; the UdU' (or LdL') factorization has +C been completed, but the block diagonal matrix d is +C exactly singular; +C = M+1: if the matrix R is numerically singular. +C +C METHOD +C - - +C The matrices G, and/or A and Q are evaluated using the given or +C computed symmetric factorization of R. +C +C NUMERICAL ASPECTS +C +C The routine should not be used when R is ill-conditioned. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER FACT, JOBG, JOBL, UPLO + INTEGER INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M, + $ N, OUFACT +C .. Array Arguments .. + INTEGER IPIV(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*), + $ L(LDL,*), Q(LDQ,*), R(LDR,*) +C .. Local Scalars .. + LOGICAL LFACTA, LFACTC, LFACTU, LJOBG, LJOBL, LUPLOU + CHARACTER TRANS + INTEGER I, J, WRKOPT + DOUBLE PRECISION EPS, RCOND, RNORM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DPOCON, DPOTRF, DSYCON, + $ DSYRK, DSYTRF, DSYTRS, DTRSM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBG = LSAME( JOBG, 'G' ) + LJOBL = LSAME( JOBL, 'N' ) + LFACTC = LSAME( FACT, 'C' ) + LFACTU = LSAME( FACT, 'U' ) + LUPLOU = LSAME( UPLO, 'U' ) + LFACTA = LFACTC.OR.LFACTU +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) THEN + INFO = -3 + ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( ( LDA.LT.1 ) .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( ( LDQ.LT.1 ) .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDR.LT.MAX( 1, M ) ) THEN + INFO = -14 + ELSE IF( ( LDL.LT.1 ) .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN + INFO = -16 + ELSE IF( ( LDG.LT.1 ) .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN + INFO = -20 + ELSE IF( ( LFACTC .AND. LDWORK.LT.1 ) .OR. + $ ( LFACTU .AND. LDWORK.LT.MAX( 1, N*M ) ) .OR. + $ ( .NOT.LFACTA .AND. LDWORK.LT.MAX( 2, N*M, 3*M ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02MT', -INFO ) + RETURN + END IF +C + IF ( LFACTC ) THEN + OUFACT = 1 + ELSE IF ( LFACTU ) THEN + OUFACT = 2 + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 .OR. .NOT.( LJOBL.OR.LJOBG ) ) THEN + DWORK(1) = ONE + IF ( .NOT.LFACTA ) DWORK(2) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = 1 +C +C Set relative machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C + IF ( .NOT.LFACTA ) THEN +C +C Compute the norm of the matrix R, which is not factored. +C Then save the given triangle of R in the other strict triangle +C and the diagonal in the workspace, and try Cholesky +C factorization. +C Workspace: need M. +C + RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + CALL DCOPY( M, R, LDR+1, DWORK, 1 ) + IF( LUPLOU ) THEN +C + DO 20 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 20 CONTINUE +C + ELSE +C + DO 40 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 40 CONTINUE +C + END IF + CALL DPOTRF( UPLO, M, R, LDR, INFO ) + IF( INFO.EQ.0 ) THEN +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 3*M. +C + CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK, + $ INFO ) +C +C Return if the matrix is singular to working precision. +C + OUFACT = 1 + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, 3*M ) + ELSE +C +C Use UdU' or LdL' factorization, first restoring the saved +C triangle. +C + CALL DCOPY( M, DWORK, 1, R, LDR+1 ) + IF( LUPLOU ) THEN +C + DO 60 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 60 CONTINUE +C + ELSE +C + DO 80 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 80 CONTINUE +C + END IF +C +C Compute the UdU' or LdL' factorization. +C Workspace: need 1, +C prefer M*NB. +C + CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) + OUFACT = 2 + IF( INFO.GT.0 ) THEN + DWORK(2) = ONE + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, + $ IWORK, INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + IF (OUFACT.EQ.1 ) THEN +C +C Solve positive definite linear system(s). +C + IF ( LUPLOU ) THEN + TRANS = 'N' + ELSE + TRANS = 'T' + END IF +C +C Solve the system X*U = B, overwriting B with X. +C + CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, + $ ONE, R, LDR, B, LDB ) +C + IF ( LJOBG ) THEN +C -1 +C Compute the matrix G = B*R *B', multiplying X*X' in G. +C + CALL DSYRK( UPLO, 'No transpose', N, M, ONE, B, LDB, ZERO, + $ G, LDG ) + END IF +C + IF( LJOBL ) THEN +C +C Update matrices A and Q. +C +C Solve the system Y*U = L, overwriting L with Y. +C + CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M, + $ ONE, R, LDR, L, LDL ) +C +C Compute A <- A - X*Y'. +C + CALL DGEMM( 'No transpose', 'Transpose', N, N, M, -ONE, B, + $ LDB, L, LDL, ONE, A, LDA ) +C +C Compute Q <- Q - Y*Y'. +C + CALL DSYRK( UPLO, 'No transpose', N, M, -ONE, L, LDL, ONE, + $ Q, LDQ ) + END IF + ELSE +C +C Solve indefinite linear system(s). +C +C Solve the system UdU'*X = B' (or LdL'*X = B'). +C Workspace: need N*M. +C + DO 100 J = 1, M + CALL DCOPY( N, B(1,J), 1, DWORK(J), M ) + 100 CONTINUE +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) +C + IF ( LJOBG ) THEN +C -1 +C Compute a triangle of the matrix G = B*R *B' = B*X. +C + IF ( LUPLOU ) THEN + I = 1 +C + DO 120 J = 1, N + CALL DGEMV( 'No transpose', J, M, ONE, B, LDB, + $ DWORK(I), 1, ZERO, G(1,J), 1 ) + I = I + M + 120 CONTINUE +C + ELSE +C + DO 140 J = 1, N + CALL DGEMV( 'Transpose', M, J, ONE, DWORK, M, B(J,1), + $ LDB, ZERO, G(J,1), LDG ) + 140 CONTINUE +C + END IF + END IF +C + IF( LJOBL ) THEN +C +C Update matrices A and Q. +C +C Solve the system UdU'*Y = L' (or LdL'*Y = L'). +C + DO 160 J = 1, M + CALL DCOPY( N, L(1,J), 1, DWORK(J), M ) + 160 CONTINUE +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO ) +C +C A <- A - B*Y. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, M, -ONE, + $ B, LDB, DWORK, M, ONE, A, LDA ) +C - -1 +C Compute a triangle of the matrix Q = Q - L*R *L' = Q - L*Y. +C + IF ( LUPLOU ) THEN + I = 1 +C + DO 180 J = 1, N + CALL DGEMV( 'No transpose', J, M, -ONE, L, LDL, + $ DWORK(I), 1, ONE, Q(1,J), 1 ) + I = I + M + 180 CONTINUE +C + ELSE +C + DO 200 J = 1, N + CALL DGEMV( 'Transpose', M, J, -ONE, DWORK, M, L(J,1), + $ LDL, ONE, Q(J,1), LDQ ) + 200 CONTINUE +C + END IF + END IF + END IF +C + DWORK(1) = WRKOPT + IF ( .NOT.LFACTA ) DWORK(2) = RCOND +C +C *** Last line of SB02MT *** + RETURN + END diff --git a/mex/sources/libslicot/SB02MU.f b/mex/sources/libslicot/SB02MU.f new file mode 100644 index 000000000..567a22476 --- /dev/null +++ b/mex/sources/libslicot/SB02MU.f @@ -0,0 +1,486 @@ + SUBROUTINE SB02MU( DICO, HINV, 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the 2n-by-2n Hamiltonian or symplectic matrix S +C associated to the linear-quadratic optimization problem, used to +C solve the continuous- or discrete-time algebraic Riccati equation, +C respectively. +C +C For a continuous-time problem, S is defined by +C +C ( A -G ) +C S = ( ), (1) +C ( -Q -A') +C +C and for a discrete-time problem by +C +C -1 -1 +C ( A A *G ) +C S = ( -1 -1 ), (2) +C ( QA A' + Q*A *G ) +C +C or +C +C -T -T +C ( A + G*A *Q -G*A ) +C S = ( -T -T ), (3) +C ( -A *Q A ) +C +C where A, G, and Q are N-by-N matrices, with G and Q symmetric. +C Matrix A must be nonsingular in the discrete-time case. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': Continuous-time system; +C = 'D': Discrete-time system. +C +C HINV CHARACTER*1 +C If DICO = 'D', specifies which of the matrices (2) or (3) +C is constructed, as follows: +C = 'D': The matrix S in (2) is constructed; +C = 'I': The (inverse) matrix S in (3) is constructed. +C HINV is not referenced if DICO = 'C'. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, and Q. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. +C On exit, if DICO = 'D', and INFO = 0, the leading N-by-N +C -1 +C part of this array contains the matrix A . +C Otherwise, the array A is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C G (input) DOUBLE PRECISION array, dimension (LDG,N) +C The leading N-by-N upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C must contain the upper triangular part or lower triangular +C part, respectively, of the symmetric matrix G. The stricly +C lower triangular part (if UPLO = 'U') or stricly upper +C triangular part (if UPLO = 'L') is not referenced. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C The leading N-by-N upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C must contain the upper triangular part or lower triangular +C part, respectively, of the symmetric matrix Q. The stricly +C lower triangular part (if UPLO = 'U') or stricly upper +C triangular part (if UPLO = 'L') is not referenced. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,N). +C +C S (output) DOUBLE PRECISION array, dimension (LDS,2*N) +C If INFO = 0, the leading 2N-by-2N part of this array +C contains the Hamiltonian or symplectic matrix of the +C problem. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,2*N). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK; if DICO = 'D', DWORK(2) returns the reciprocal +C condition number of the given matrix A. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 1 if DICO = 'C'; +C LDWORK >= MAX(2,4*N) if DICO = 'D'. +C For optimum performance LDWORK should be larger, if +C DICO = 'D'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the leading i-by-i (1 <= i <= N) upper triangular +C submatrix of A is singular in discrete-time case; +C = N+1: if matrix A is numerically singular in discrete- +C time case. +C +C METHOD +C +C For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1) +C is constructed. +C For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or +C (3) - the inverse of the matrix in (2) - is constructed. +C +C NUMERICAL ASPECTS +C +C The discrete-time case needs the inverse of the matrix A, hence +C the routine should not be used when A is ill-conditioned. +C 3 +C The algorithm requires 0(n ) floating point operations in the +C discrete-time case. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, HINV, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDS, LDWORK, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*), + $ S(LDS,*) +C .. Local Scalars .. + LOGICAL DISCR, LHINV, LUPLO + INTEGER I, J, MAXWRK, N2, NJ, NP1 + DOUBLE PRECISION ANORM, RCOND +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGECON, DGEMM, DGETRF, DGETRI, DGETRS, + $ DLACPY, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + N2 = N + N + DISCR = LSAME( DICO, 'D' ) + LUPLO = LSAME( UPLO, 'U' ) + IF( DISCR ) THEN + LHINV = LSAME( HINV, 'D' ) + ELSE + LHINV = .FALSE. + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( DISCR ) THEN + IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) ) + $ INFO = -2 + END IF + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN + INFO = -12 + ELSE IF( ( LDWORK.LT.1 ) .OR. + $ ( DISCR .AND. LDWORK.LT.MAX( 2, 4*N ) ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02MU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = ONE + IF ( DISCR ) DWORK(2) = ONE + RETURN + END IF +C +C The code tries to exploit data locality as much as possible. +C + IF ( .NOT.LHINV ) THEN + CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) +C +C Construct Hamiltonian matrix in the continuous-time case, or +C prepare symplectic matrix in (3) in the discrete-time case: +C +C Construct full Q in S(N+1:2*N,1:N) and change the sign, and +C construct full G in S(1:N,N+1:2*N) and change the sign. +C + DO 200 J = 1, N + NJ = N + J + IF ( LUPLO ) THEN +C + DO 20 I = 1, J + S(N+I,J) = -Q(I,J) + 20 CONTINUE +C + DO 40 I = J + 1, N + S(N+I,J) = -Q(J,I) + 40 CONTINUE +C + DO 60 I = 1, J + S(I,NJ) = -G(I,J) + 60 CONTINUE +C + DO 80 I = J + 1, N + S(I,NJ) = -G(J,I) + 80 CONTINUE +C + ELSE +C + DO 100 I = 1, J - 1 + S(N+I,J) = -Q(J,I) + 100 CONTINUE +C + DO 120 I = J, N + S(N+I,J) = -Q(I,J) + 120 CONTINUE +C + DO 140 I = 1, J - 1 + S(I,NJ) = -G(J,I) + 140 CONTINUE +C + DO 180 I = J, N + S(I,NJ) = -G(I,J) + 180 CONTINUE +C + END IF + 200 CONTINUE +C + IF ( .NOT.DISCR ) THEN +C + DO 240 J = 1, N + NJ = N + J +C + DO 220 I = 1, N + S(N+I,NJ) = -A(J,I) + 220 CONTINUE +C + 240 CONTINUE +C + DWORK(1) = ONE + END IF + END IF +C + IF ( DISCR ) THEN +C +C Construct the symplectic matrix (2) or (3) in the discrete-time +C case. +C +C Compute workspace. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of workspace needed at that point in the code, +C as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + MAXWRK = MAX( 4*N, + $ N*ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) ) + NP1 = N + 1 +C + IF ( LHINV ) THEN +C +C Put A' in S(N+1:2*N,N+1:2*N). +C + DO 260 I = 1, N + CALL DCOPY( N, A(I, 1), LDA, S(NP1,N+I), 1 ) + 260 CONTINUE +C + END IF +C +C Compute the norm of the matrix A. +C + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) +C +C Compute the LU factorization of A. +C + CALL DGETRF( N, N, A, LDA, IWORK, INFO ) +C +C Return if INFO is non-zero. +C + IF( INFO.GT.0 ) THEN + DWORK(2) = ZERO + RETURN + END IF +C +C Compute the reciprocal of the condition number of A. +C Workspace: need 4*N. +C + CALL DGECON( '1-norm', N, A, LDA, ANORM, RCOND, DWORK, + $ IWORK(NP1), INFO ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN + INFO = N + 1 + DWORK(2) = RCOND + RETURN + END IF +C + IF ( LHINV ) THEN +C +C Compute S in (2). +C +C Construct full Q in S(N+1:2*N,1:N). +C + IF ( LUPLO ) THEN + DO 270 J = 1, N - 1 + CALL DCOPY( J, Q(1,J), 1, S(NP1,J), 1 ) + CALL DCOPY( N-J, Q(J,J+1), LDQ, S(NP1+J,J), 1 ) + 270 CONTINUE + CALL DCOPY( N, Q(1,N), 1, S(NP1,N), 1 ) + ELSE + CALL DCOPY( N, Q(1,1), 1, S(NP1,1), 1 ) + DO 280 J = 2, N + CALL DCOPY( J-1, Q(J,1), LDQ, S(NP1,J), 1 ) + CALL DCOPY( N-J+1, Q(J,J), 1, S(N+J,J), 1 ) + 280 CONTINUE + END IF +C +C Compute the solution matrix X of the system X*A = Q by +C -1 +C solving A'*X' = Q and transposing the result to get Q*A . +C + CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), + $ LDS, INFO ) +C + DO 300 J = 1, N - 1 + CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS ) + 300 CONTINUE +C +C Construct full G in S(1:N,N+1:2*N). +C + IF ( LUPLO ) THEN + DO 310 J = 1, N - 1 + CALL DCOPY( J, G(1,J), 1, S(1,N+J), 1 ) + CALL DCOPY( N-J, G(J,J+1), LDG, S(J+1,N+J), 1 ) + 310 CONTINUE + CALL DCOPY( N, G(1,N), 1, S(1,N2), 1 ) + ELSE + CALL DCOPY( N, G(1,1), 1, S(1,NP1), 1 ) + DO 320 J = 2, N + CALL DCOPY( J-1, G(J,1), LDG, S(1,N+J), 1 ) + CALL DCOPY( N-J+1, G(J,J), 1, S(J,N+J), 1 ) + 320 CONTINUE + END IF +C -1 +C Compute A' + Q*A *G in S(N+1:2N,N+1:2N). +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ S(NP1,1), LDS, S(1,NP1), LDS, ONE, S(NP1,NP1), + $ LDS ) +C +C Compute the solution matrix Y of the system A*Y = G. +C + CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), + $ LDS, INFO ) +C +C Compute the inverse of A in situ. +C Workspace: need N; prefer N*NB. +C + CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) +C -1 +C Copy A in S(1:N,1:N). +C + CALL DLACPY( 'Full', N, N, A, LDA, S, LDS ) +C + ELSE +C +C Compute S in (3) using the already prepared part. +C +C Compute the solution matrix X' of the system A*X' = -G +C -T +C and transpose the result to obtain X = -G*A . +C + CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1), + $ LDS, INFO ) +C + DO 340 J = 1, N - 1 + CALL DSWAP( N-J, S(J+1,N+J), 1, S(J,NP1+J), LDS ) + 340 CONTINUE +C -T +C Compute A + G*A *Q in S(1:N,1:N). +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, + $ S(1,NP1), LDS, S(NP1, 1), LDS, ONE, S, LDS ) +C +C Compute the solution matrix Y of the system A'*Y = -Q. +C + CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1), + $ LDS, INFO ) +C +C Compute the inverse of A in situ. +C Workspace: need N; prefer N*NB. +C + CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO ) +C -T +C Copy A in S(N+1:2N,N+1:2N). +C + DO 360 J = 1, N + CALL DCOPY( N, A(J,1), LDA, S(NP1,N+J), 1 ) + 360 CONTINUE +C + END IF + DWORK(1) = MAXWRK + DWORK(2) = RCOND + END IF +C +C *** Last line of SB02MU *** + RETURN + END diff --git a/mex/sources/libslicot/SB02MV.f b/mex/sources/libslicot/SB02MV.f new file mode 100644 index 000000000..5dc8e2452 --- /dev/null +++ b/mex/sources/libslicot/SB02MV.f @@ -0,0 +1,75 @@ + LOGICAL FUNCTION SB02MV( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02MW.f b/mex/sources/libslicot/SB02MW.f new file mode 100644 index 000000000..eb54ebae9 --- /dev/null +++ b/mex/sources/libslicot/SB02MW.f @@ -0,0 +1,79 @@ + LOGICAL FUNCTION SB02MW( REIG, IEIG ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02ND.f b/mex/sources/libslicot/SB02ND.f new file mode 100644 index 000000000..1f446c023 --- /dev/null +++ b/mex/sources/libslicot/SB02ND.f @@ -0,0 +1,755 @@ + SUBROUTINE SB02ND( DICO, FACT, UPLO, JOBL, N, M, P, A, LDA, B, + $ LDB, R, LDR, IPIV, L, LDL, X, LDX, RNORM, F, + $ LDF, OUFACT, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the optimal feedback matrix F for the problem of +C optimal control given by +C +C -1 +C F = (R + B'XB) (B'XA + L') (1) +C +C in the discrete-time case and +C +C -1 +C F = R (B'X + L') (2) +C +C in the continuous-time case, where A, B and L are N-by-N, N-by-M +C and N-by-M matrices respectively; R and X are M-by-M and N-by-N +C symmetric matrices respectively. +C +C Optionally, matrix R may be specified in a factored form, and L +C may be zero. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the equation from which F is to be determined, +C as follows: +C = 'D': Equation (1), discrete-time case; +C = 'C': Equation (2), continuous-time case. +C +C FACT CHARACTER*1 +C Specifies how the matrix R is given (factored or not), as +C follows: +C = 'N': Array R contains the matrix R; +C = 'D': Array R contains a P-by-M matrix D, where R = D'D; +C = 'C': Array R contains the Cholesky factor of R; +C = 'U': Array R contains the symmetric indefinite UdU' or +C LdL' factorization of R. This option is not +C available for DICO = 'D'. +C +C UPLO CHARACTER*1 +C Specifies which triangle of the possibly factored matrix R +C (or R + B'XB, on exit) is or should be stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A and X. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C This parameter must be specified only for FACT = 'D'. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If DICO = 'D', the leading N-by-N part of this array must +C contain the state matrix A of the system. +C If DICO = 'C', this array is not referenced. +C +C LDA INTEGER +C The leading dimension of array A. +C LDA >= MAX(1,N) if DICO = 'D'; +C LDA >= 1 if DICO = 'C'. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the system. +C If DICO = 'D' and FACT = 'D' or 'C', the contents of this +C array is destroyed. +C Otherwise, B is unchanged on exit. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,M) +C On entry, if FACT = 'N', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the upper +C triangular part or lower triangular part, respectively, +C of the symmetric input weighting matrix R. +C On entry, if FACT = 'D', the leading P-by-M part of this +C array must contain the direct transmission matrix D of the +C system. +C On entry, if FACT = 'C', the leading M-by-M upper +C triangular part (if UPLO = 'U') or lower triangular part +C (if UPLO = 'L') of this array must contain the Cholesky +C factor of the positive definite input weighting matrix R +C (as produced by LAPACK routine DPOTRF). +C On entry, if DICO = 'C' and FACT = 'U', the leading M-by-M +C upper triangular part (if UPLO = 'U') or lower triangular +C part (if UPLO = 'L') of this array must contain the +C factors of the UdU' or LdL' factorization, respectively, +C of the symmetric indefinite input weighting matrix R (as +C produced by LAPACK routine DSYTRF). +C The stricly lower triangular part (if UPLO = 'U') or +C stricly upper triangular part (if UPLO = 'L') of this +C array is used as workspace. +C On exit, if OUFACT(1) = 1, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the Cholesky factor of the given input weighting +C matrix (for DICO = 'C'), or that of the matrix R + B'XB +C (for DICO = 'D'). +C On exit, if OUFACT(1) = 2, and INFO = 0 (or INFO = M+1), +C the leading M-by-M upper triangular part (if UPLO = 'U') +C or lower triangular part (if UPLO = 'L') of this array +C contains the factors of the UdU' or LdL' factorization, +C respectively, of the given input weighting matrix +C (for DICO = 'C'), or that of the matrix R + B'XB +C (for DICO = 'D'). +C On exit R is unchanged if FACT = 'U'. +C +C LDR INTEGER. +C The leading dimension of the array R. +C LDR >= MAX(1,M) if FACT <> 'D'; +C LDR >= MAX(1,M,P) if FACT = 'D'. +C +C IPIV (input/output) INTEGER array, dimension (M) +C On entry, if FACT = 'U', this array must contain details +C of the interchanges performed and the block structure of +C the d factor in the UdU' or LdL' factorization of matrix R +C (as produced by LAPACK routine DSYTRF). +C On exit, if OUFACT(1) = 2, this array contains details of +C the interchanges performed and the block structure of the +C d factor in the UdU' or LdL' factorization of matrix R (or +C D'D) or R + B'XB (or D'D + B'XB), as produced by LAPACK +C routine DSYTRF. +C This array is not referenced for DICO = 'D' or FACT = 'D', +C or 'C'. +C +C L (input) DOUBLE PRECISION array, dimension (LDL,M) +C If JOBL = 'N', the leading N-by-M part of this array must +C contain the cross weighting matrix L. +C If JOBL = 'Z', this array is not referenced. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N'; +C LDL >= 1 if JOBL = 'Z'. +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading N-by-N part of this array must +C contain the solution matrix X of the algebraic Riccati +C equation as produced by SLICOT Library routines SB02MD or +C SB02OD. Matrix X is assumed non-negative definite. +C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 1, +C and INFO = 0, the N-by-N upper triangular part of this +C array contains the Cholesky factor of the given matrix X, +C which is found to be positive definite. +C On exit, if DICO = 'D', FACT = 'D' or 'C', OUFACT(2) = 2, +C and INFO = 0, the leading N-by-N part of this array +C contains the matrix of orthonormal eigenvectors of X. +C On exit X is unchanged if DICO = 'C' or FACT = 'N'. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C RNORM (input) DOUBLE PRECISION +C If FACT = 'U', this parameter must contain the 1-norm of +C the original matrix R (before factoring it). +C Otherwise, this parameter is not used. +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the +C optimal feedback matrix F. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C OUFACT (output) INTEGER array, dimension (2) +C Information about the factorization finally used. +C OUFACT(1) = 1: Cholesky factorization of R (or R + B'XB) +C has been used; +C OUFACT(1) = 2: UdU' (if UPLO = 'U') or LdL' (if UPLO = +C 'L') factorization of R (or R + B'XB) +C has been used; +C OUFACT(2) = 1: Cholesky factorization of X has been used; +C OUFACT(2) = 2: Spectral factorization of X has been used. +C The value of OUFACT(2) is not set for DICO = 'C' or for +C DICO = 'D' and FACT = 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2) contains the reciprocal condition +C number of the matrix R (for DICO = 'C') or of R + B'XB +C (for DICO = 'D'). +C If on exit INFO = 0, and OUFACT(2) = 2, then DWORK(3),..., +C DWORK(N+2) contain the eigenvalues of X, in ascending +C order. +C +C LDWORK INTEGER +C Dimension of working array DWORK. +C LDWORK >= max(2,3*M) if FACT = 'N'; +C LDWORK >= max(2,2*M) if FACT = 'U'; +C LDWORK >= max(2,3*M) if FACT = 'C', DICO = 'C'; +C LDWORK >= N+3*M+2 if FACT = 'C', DICO = 'D'; +C LDWORK >= max(2,min(P,M)+M) if FACT = 'D', DICO = 'C'; +C LDWORK >= max(N+3*M+2,4*N+1) if FACT = 'D', DICO = 'D'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if the i-th element of the d factor is exactly zero; +C the UdU' (or LdL') factorization has been completed, +C but the block diagonal matrix d is exactly singular; +C = M+1: if the matrix R (if DICO = 'C'), or R + B'XB +C (if DICO = 'D') is numerically singular (to working +C precision); +C = M+2: if one or more of the eigenvalues of X has not +C converged. +C +C METHOD +C +C The optimal feedback matrix F is obtained as the solution to the +C system of linear equations +C +C (R + B'XB) * F = B'XA + L' +C +C in the discrete-time case and +C +C R * F = B'X + L' +C +C in the continuous-time case, with R replaced by D'D if FACT = 'D'. +C The factored form of R, specified by FACT <> 'N', is taken into +C account. If FACT = 'N', Cholesky factorization is tried first, but +C if the coefficient matrix is not positive definite, then UdU' (or +C LdL') factorization is used. The discrete-time case involves +C updating of a triangular factorization of R (or D'D); Cholesky or +C symmetric spectral factorization of X is employed to avoid +C squaring of the condition number of the matrix. When D is given, +C its QR factorization is determined, and the triangular factor is +C used as described above. +C +C NUMERICAL ASPECTS +C +C The algorithm consists of numerically stable steps. +C 3 2 +C For DICO = 'C', it requires O(m + mn ) floating point operations +C 2 +C if FACT = 'N' and O(mn ) floating point operations, otherwise. +C For DICO = 'D', the operation counts are similar, but additional +C 3 +C O(n ) floating point operations may be needed in the worst case. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, matrix algebra, optimal control, +C optimal regulator. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOBL, UPLO + INTEGER INFO, LDA, LDB, LDF, LDL, LDR, LDWORK, LDX, M, + $ N, P + DOUBLE PRECISION RNORM +C .. Array Arguments .. + INTEGER IPIV(*), IWORK(*), OUFACT(2) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), + $ L(LDL,*), R(LDR,*), X(LDX,*) +C .. Local Scalars .. + LOGICAL DISCR, LFACTA, LFACTC, LFACTD, LFACTU, LUPLOU, + $ WITHL + INTEGER I, IFAIL, ITAU, J, JW, JWORK, JZ, WRKOPT + DOUBLE PRECISION EPS, RCOND, RNORMP, TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUMMY(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DLASET, DPOCON, + $ DPOTRF, DPOTRS, DSCAL, DSYCON, DSYEV, DSYTRF, + $ DSYTRS, DTRCON, DTRMM, MB04KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LFACTC = LSAME( FACT, 'C' ) + LFACTD = LSAME( FACT, 'D' ) + LFACTU = LSAME( FACT, 'U' ) + LUPLOU = LSAME( UPLO, 'U' ) + WITHL = LSAME( JOBL, 'N' ) + LFACTA = LFACTC.OR.LFACTD.OR.LFACTU +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( ( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) .OR. + $ ( DISCR .AND. LFACTU ) ) THEN + INFO = -2 + ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -3 + ELSE IF( .NOT.WITHL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( ( .NOT.DISCR .AND. LDA.LT.1 ) .OR. + $ ( DISCR .AND. LDA.LT.MAX( 1, N ) ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( ( LDR.LT.MAX( 1, M ) ) .OR. + $ ( LFACTD .AND. LDR.LT.MAX( 1, P ) ) ) THEN + INFO = -13 + ELSE IF( ( .NOT.WITHL .AND. LDL.LT.1 ) .OR. + $ ( WITHL .AND. LDL.LT.MAX( 1, N ) ) ) THEN + INFO = -16 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LFACTU ) THEN + IF( RNORM.LT.ZERO ) + $ INFO = -19 + END IF + IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -21 + ELSE IF( ( ( .NOT.LFACTA .OR. ( LFACTC .AND. .NOT.DISCR ) ) + $ .AND. LDWORK.LT.MAX( 2, 3*M ) ) .OR. + $ ( LFACTU .AND. LDWORK.LT.MAX( 2, 2*M ) ) .OR. + $ ( DISCR .AND. LFACTC .AND. LDWORK.LT.N + 3*M + 2 ) .OR. + $(.NOT.DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( 2, MIN(P,M) + M ) ) + $ .OR. + $ ( DISCR .AND. LFACTD .AND. LDWORK.LT.MAX( N + 3*M + 2, + $ 4*N + 1 ) ) ) THEN + INFO = -25 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB02ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 .OR. ( LFACTD .AND. P.EQ.0 ) ) THEN + DWORK(1) = ONE + DWORK(2) = ONE + RETURN + END IF +C + WRKOPT = 1 + EPS = DLAMCH( 'Epsilon' ) +C +C Determine the right-hand side of the matrix equation. +C Compute B'X in F. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DGEMM( 'Transpose', 'No transpose', M, N, N, ONE, B, LDB, X, + $ LDX, ZERO, F, LDF ) +C + IF ( .NOT.LFACTA ) THEN + IF ( DISCR ) THEN +C +C Discrete-time case with R not factored. Compute R + B'XB. +C + IF ( LUPLOU ) THEN +C + DO 10 J = 1, M + CALL DGEMV( 'No transpose', J, N, ONE, F, LDF, B(1,J), + $ 1, ONE, R(1,J), 1 ) + 10 CONTINUE +C + ELSE +C + DO 20 J = 1, M + CALL DGEMV( 'Transpose', N, J, ONE, B, LDB, F(J,1), + $ LDF, ONE, R(J,1), LDR ) + 20 CONTINUE +C + END IF + END IF +C +C Compute the 1-norm of the matrix R or R + B'XB. +C Workspace: need M. +C + RNORMP = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + WRKOPT = MAX( WRKOPT, M ) + END IF +C + IF ( DISCR ) THEN +C +C For discrete-time case, postmultiply B'X by A. +C Workspace: need N. +C + DO 30 I = 1, M + CALL DCOPY( N, F(I,1), LDF, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, A, LDA, DWORK, 1, ZERO, + $ F(I,1), LDF ) + 30 CONTINUE +C + WRKOPT = MAX( WRKOPT, N ) + END IF +C + IF( WITHL ) THEN +C +C Add L'. +C + DO 50 I = 1, M +C + DO 40 J = 1, N + F(I,J) = F(I,J) + L(J,I) + 40 CONTINUE +C + 50 CONTINUE +C + END IF +C +C Solve the matrix equation. +C + IF ( LFACTA ) THEN +C +C Case 1: Matrix R is given in a factored form. +C + IF ( LFACTD ) THEN +C +C Use QR factorization of D. +C Workspace: need min(P,M) + M, +C prefer min(P,M) + M*NB. +C + ITAU = 1 + JWORK = ITAU + MIN( P, M ) + CALL DGEQRF( P, M, R, LDR, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Make positive the diagonal elements of the triangular +C factor. Construct the strictly lower triangle, if requested. +C + DO 70 I = 1, M + IF ( R(I,I).LT.ZERO ) THEN +C + DO 60 J = I, M + R(I,J) = -R(I,J) + 60 CONTINUE +C + END IF + IF ( .NOT.LUPLOU ) + $ CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) + 70 CONTINUE +C + IF ( P.LT.M ) THEN + CALL DLASET( 'Full', M-P, M, ZERO, ZERO, R(P+1,1), LDR ) + IF ( .NOT.DISCR ) THEN + DWORK(2) = ZERO + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + JW = 1 + IF ( DISCR ) THEN +C +C Discrete-time case. Update the factorization for B'XB. +C Try first the Cholesky factorization of X, saving the +C diagonal of X, in order to recover it, if X is not positive +C definite. In the later case, use spectral factorization. +C Workspace: need N. +C Define JW = 1 for Cholesky factorization of X, +C JW = N+3 for spectral factorization of X. +C + CALL DCOPY( N, X, LDX+1, DWORK, 1 ) + CALL DPOTRF( 'Upper', N, X, LDX, IFAIL ) + IF ( IFAIL.EQ.0 ) THEN +C +C Use Cholesky factorization of X to compute chol(X)*B. +C + OUFACT(2) = 1 + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non unit', + $ N, M, ONE, X, LDX, B, LDB ) + ELSE +C +C Use spectral factorization of X, X = UVU'. +C Workspace: need 4*N+1, +C prefer N*(NB+2)+N+2. +C + JW = N + 3 + OUFACT(2) = 2 + CALL DCOPY( N, DWORK, 1, X, LDX+1 ) + CALL DSYEV( 'Vectors', 'Lower', N, X, LDX, DWORK(3), + $ DWORK(JW), LDWORK-JW+1, IFAIL ) + IF ( IFAIL.GT.0 ) THEN + INFO = M + 2 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JW) )+JW-1 ) + TEMP = ABS( DWORK(N+2) )*EPS +C +C Count the negligible eigenvalues and compute sqrt(V)U'B. +C Workspace: need 2*N+2. +C + JZ = 0 +C + 80 CONTINUE + IF ( ABS( DWORK(JZ+3) ).LE.TEMP ) THEN + JZ = JZ + 1 + IF ( JZ.LT.N) GO TO 80 + END IF +C + DO 90 J = 1, M + CALL DCOPY( N, B(1,J), 1, DWORK(JW), 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, X, LDX, DWORK(JW), + $ 1, ZERO, B(1,J), 1 ) + 90 CONTINUE +C + DO 100 I = JZ + 1, N + CALL DSCAL( M, SQRT( ABS( DWORK(I+2) ) ), B(I,1), LDB + $ ) + 100 CONTINUE +C + IF ( JZ.GT.0 ) + $ CALL DLASET( 'Full', JZ, M, ZERO, ZERO, B, LDB ) + END IF +C +C Update the triangular factorization. +C + IF ( .NOT.LUPLOU ) THEN +C +C For efficiency, use the transposed of the lower triangle. +C + DO 110 I = 2, M + CALL DCOPY( I-1, R(I,1), LDR, R(1,I), 1 ) + 110 CONTINUE +C + END IF +C +C Workspace: need JW+2*M-1. +C + CALL MB04KD( 'Full', M, 0, N, R, LDR, B, LDB, DUMMY, N, + $ DUMMY, M, DWORK(JW), DWORK(JW+N) ) + WRKOPT = MAX( WRKOPT, JW + 2*M - 1 ) +C +C Make positive the diagonal elements of the triangular +C factor. +C + DO 130 I = 1, M + IF ( R(I,I).LT.ZERO ) THEN +C + DO 120 J = I, M + R(I,J) = -R(I,J) + 120 CONTINUE +C + END IF + 130 CONTINUE +C + IF ( .NOT.LUPLOU ) THEN +C +C Construct the lower triangle. +C + DO 140 I = 2, M + CALL DCOPY( I-1, R(1,I), 1, R(I,1), LDR ) + 140 CONTINUE +C + END IF + END IF +C +C Compute the condition number of the coefficient matrix. +C + IF ( .NOT.LFACTU ) THEN +C +C Workspace: need JW+3*M-1. +C + CALL DTRCON( '1-norm', UPLO, 'Non unit', M, R, LDR, RCOND, + $ DWORK(JW), IWORK, IFAIL ) + OUFACT(1) = 1 + WRKOPT = MAX( WRKOPT, JW + 3*M - 1 ) + ELSE +C +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK, + $ IWORK, INFO ) + OUFACT(1) = 2 + WRKOPT = MAX( WRKOPT, 2*M ) + END IF + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF +C + ELSE +C +C Case 2: Matrix R is given in an unfactored form. +C +C Save the given triangle of R or R + B'XB in the other +C strict triangle and the diagonal in the workspace, and try +C Cholesky factorization. +C Workspace: need M. +C + CALL DCOPY( M, R, LDR+1, DWORK, 1 ) + IF( LUPLOU ) THEN +C + DO 150 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 150 CONTINUE +C + ELSE +C + DO 160 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 160 CONTINUE +C + END IF + CALL DPOTRF( UPLO, M, R, LDR, INFO ) + OUFACT(1) = 1 + IF( INFO.EQ.0 ) THEN +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 3*M. +C + CALL DPOCON( UPLO, M, R, LDR, RNORMP, RCOND, DWORK, IWORK, + $ INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, 3*M ) + ELSE +C +C Use UdU' or LdL' factorization, first restoring the saved +C triangle. +C + CALL DCOPY( M, DWORK, 1, R, LDR+1 ) + IF( LUPLOU ) THEN +C + DO 170 J = 2, M + CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 ) + 170 CONTINUE +C + ELSE +C + DO 180 J = 2, M + CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR ) + 180 CONTINUE +C + END IF +C +C Workspace: need 1, +C prefer M*NB. +C + CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO ) + OUFACT(1) = 2 + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Compute the reciprocal of the condition number of R. +C Workspace: need 2*M. +C + CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORMP, RCOND, DWORK, + $ IWORK, INFO ) +C +C Return if the matrix is singular to working precision. +C + DWORK(2) = RCOND + IF( RCOND.LT.EPS ) THEN + INFO = M + 1 + RETURN + END IF + END IF + END IF +C + IF (OUFACT(1).EQ.1 ) THEN +C +C Solve the positive definite linear system. +C + CALL DPOTRS( UPLO, M, N, R, LDR, F, LDF, INFO ) + ELSE +C +C Solve the indefinite linear system. +C + CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, F, LDF, INFO ) + END IF +C +C Set the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB02ND *** + END diff --git a/mex/sources/libslicot/SB02OD.f b/mex/sources/libslicot/SB02OD.f new file mode 100644 index 000000000..7408ba397 --- /dev/null +++ b/mex/sources/libslicot/SB02OD.f @@ -0,0 +1,856 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02OU.f b/mex/sources/libslicot/SB02OU.f new file mode 100644 index 000000000..530d202f6 --- /dev/null +++ b/mex/sources/libslicot/SB02OU.f @@ -0,0 +1,83 @@ + LOGICAL FUNCTION SB02OU( ALPHAR, ALPHAI, BETA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02OV.f b/mex/sources/libslicot/SB02OV.f new file mode 100644 index 000000000..db114ae96 --- /dev/null +++ b/mex/sources/libslicot/SB02OV.f @@ -0,0 +1,88 @@ + LOGICAL FUNCTION SB02OV( ALPHAR, ALPHAI, BETA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02OW.f b/mex/sources/libslicot/SB02OW.f new file mode 100644 index 000000000..11de0b233 --- /dev/null +++ b/mex/sources/libslicot/SB02OW.f @@ -0,0 +1,83 @@ + LOGICAL FUNCTION SB02OW( ALPHAR, ALPHAI, BETA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02OX.f b/mex/sources/libslicot/SB02OX.f new file mode 100644 index 000000000..b3f90b53b --- /dev/null +++ b/mex/sources/libslicot/SB02OX.f @@ -0,0 +1,87 @@ + LOGICAL FUNCTION SB02OX( ALPHAR, ALPHAI, BETA ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To select the stable generalized eigenvalues for solving the +C discrete-time algebraic Riccati equation. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ALPHAR (input) DOUBLE PRECISION +C The real part of the numerator of the current eigenvalue +C considered. +C +C ALPHAI (input) DOUBLE PRECISION +C The imaginary part of the numerator of the current +C eigenvalue considered. +C +C BETA (input) DOUBLE PRECISION +C The (real) denominator of the current eigenvalue +C considered. +C +C METHOD +C +C The function value SB02OX is set to .TRUE. for a stable eigenvalue +C (i.e., with modulus less than one) and to .FALSE., otherwise. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB02CX by P. Van Dooren, Philips +C Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, optimal regulator, Schur form. +C +C ****************************************************************** +C + 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 + SB02OX = DLAPY2( ALPHAR, ALPHAI ).LT.ABS( BETA ) +C + RETURN +C *** Last line of SB02OX *** + END diff --git a/mex/sources/libslicot/SB02OY.f b/mex/sources/libslicot/SB02OY.f new file mode 100644 index 000000000..367befee2 --- /dev/null +++ b/mex/sources/libslicot/SB02OY.f @@ -0,0 +1,791 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02PD.f b/mex/sources/libslicot/SB02PD.f new file mode 100644 index 000000000..fe63ddfca --- /dev/null +++ b/mex/sources/libslicot/SB02PD.f @@ -0,0 +1,756 @@ + SUBROUTINE SB02PD( JOB, TRANA, UPLO, N, A, LDA, G, LDG, Q, LDQ, X, + $ LDX, RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real continuous-time matrix algebraic Riccati +C equation +C +C op(A)'*X + X*op(A) + Q - X*G*X = 0, +C +C where op(A) = A or A' = A**T and G, Q are symmetric (G = G**T, +C Q = Q**T). The matrices A, G and Q are N-by-N and the solution X +C is an N-by-N symmetric matrix. +C +C An error bound on the solution and a condition estimate are also +C optionally provided. +C +C It is assumed that the matrices A, G and Q are such that the +C corresponding Hamiltonian matrix has N eigenvalues with negative +C real parts. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'A': Compute all: the solution, reciprocal condition +C number, and the error bound. +C +C TRANA CHARACTER*1 +C Specifies the option op(A): +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which triangle of the matrices G and Q is +C stored, as follows: +C = 'U': Upper triangles of G and Q are stored; +C = 'L': Lower triangles of G and Q are stored. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, G, Q, and X. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C G (input) DOUBLE PRECISION array, dimension (LDG,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix G. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix G. +C +C LDG INTEGER +C The leading dimension of the array G. LDG >= max(1,N). +C +C Q (input) DOUBLE PRECISION array, dimension (LDQ,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix Q. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix Q. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C If INFO = 0, INFO = 2, or INFO = 4, the leading N-by-N +C part of this array contains the symmetric solution matrix +C X of the algebraic Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'A', the estimate of the reciprocal condition +C number of the Riccati equation. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'A', the estimated forward error bound for the +C solution X. If XTRUE is the true solution, FERR bounds the +C magnitude of the largest entry in (X - XTRUE) divided by +C the magnitude of the largest entry in X. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If JOB = 'A' and TRANA = 'N', WR and WI contain the real +C and imaginary parts, respectively, of the eigenvalues of +C the matrix A - G*X, i.e., the closed-loop system poles. +C If JOB = 'A' and TRANA = 'T' or 'C', WR and WI contain the +C real and imaginary parts, respectively, of the eigenvalues +C of the matrix A - X*G, i.e., the closed-loop system poles. +C If JOB = 'X', these arrays are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK >= 2*N, if JOB = 'X'; +C LIWORK >= max(2*N,N*N), if JOB = 'A'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = 2, DWORK(1) contains the +C optimal value of LDWORK. If JOB = 'A', then DWORK(2:N*N+1) +C and DWORK(N*N+2:2*N*N+1) contain a real Schur form of the +C closed-loop system matrix, Ac = A - G*X (if TRANA = 'N') +C or Ac = A - X*G (if TRANA = 'T' or 'C'), and the +C orthogonal matrix which reduced Ac to real Schur form, +C respectively. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 4*N*N + 8*N + 1, if JOB = 'X'; +C LDWORK >= max( 4*N*N + 8*N, 6*N*N ) + 1, if JOB = 'A'. +C For good performance, LDWORK should be larger, e.g., +C LDWORK >= 4*N*N + 6*N +( 2*N+1 )*NB, if JOB = 'X', +C where NB is the optimal blocksize. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the Hamiltonian matrix has eigenvalues on the +C imaginary axis, so the solution and error bounds +C could not be computed; +C = 2: the iteration for the matrix sign function failed to +C converge after 50 iterations, but an approximate +C solution and error bounds (if JOB = 'A') have been +C computed; +C = 3: the system of linear equations for the solution is +C singular to working precision, so the solution and +C error bounds could not be computed; +C = 4: the matrix A-G*X (or A-X*G) cannot be reduced to +C Schur canonical form and condition number estimate +C and forward error estimate have not been computed. +C +C METHOD +C +C The Riccati equation is solved by the matrix sign function +C approach [1], [2], implementing a scaling which enhances the +C numerical stability [4]. +C +C REFERENCES +C +C [1] Bai, Z., Demmel, J., Dongarra, J., Petitet, A., Robinson, H., +C and Stanley, K. +C The spectral decomposition of nonsymmetric matrices on +C distributed memory parallel computers. +C SIAM J. Sci. Comput., vol. 18, pp. 1446-1461, 1997. +C +C [2] Byers, R., He, C., and Mehrmann, V. +C The matrix sign function method and the computation of +C invariant subspaces. +C SIAM J. Matrix Anal. Appl., vol. 18, pp. 615-632, 1997. +C +C [3] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V., +C DGRSVX and DMSRIC: Fortran 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Technical +C University Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C +C The solution accuracy can be controlled by the output parameter +C FERR. +C +C FURTHER COMMENTS +C +C The condition number of the Riccati equation is estimated as +C +C cond = ( norm(Theta)*norm(A) + norm(inv(Omega))*norm(Q) + +C norm(Pi)*norm(G) ) / norm(X), +C +C where Omega, Theta and Pi are linear operators defined by +C +C Omega(W) = op(Ac)'*W + W*op(Ac), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))), +C Pi(W) = inv(Omega(X*W*X)), +C +C and the matrix Ac (the closed-loop system matrix) is given by +C Ac = A - G*X, if TRANA = 'N', or +C Ac = A - X*G, if TRANA = 'T' or 'C'. +C +C The program estimates the quantities +C +C sep(op(Ac),-op(Ac)') = 1 / norm(inv(Omega)), +C +C norm(Theta) and norm(Pi) using 1-norm condition estimator. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [3]. +C +C CONTRIBUTOR +C +C P. Petkov, Tech. University of Sofia, March 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, continuous-time system, +C optimal control, optimal regulator. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER MAXIT + PARAMETER ( MAXIT = 50 ) + DOUBLE PRECISION ZERO, HALF, ONE, TWO, TEN + PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0, TEN = 10.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER JOB, TRANA, UPLO + INTEGER INFO, LDA, LDG, LDQ, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), DWORK( * ), G( LDG, * ), + $ Q( LDQ, * ), WI( * ), WR( * ), X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL ALL, LOWER, NOTRNA + CHARACTER EQUED, LOUP + INTEGER I, IAF, IB, IBR, IC, IFR, IJ, IJ1, IJ2, INFO2, + $ INI, IR, ISCL, ISV, IT, ITAU, ITER, IU, IWRK, + $ J, JI, LWAMAX, MINWRK, N2, SDIM + DOUBLE PRECISION CONV, GNORM2, EPS, HNORM, HINNRM, QNORM2, + $ SCALE, SEP, TEMP, TOL +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY, ILAENV, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEQP3, DGESVX, DLACPY, DLASCL, + $ DLASET, DORMQR, DSCAL, DSWAP, DSYMM, DSYTRF, + $ DSYTRI, MA02AD, MA02ED, SB02QD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + ALL = LSAME( JOB, 'A' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) +C + INFO = 0 + IF( .NOT.ALL .AND. .NOT.LSAME( JOB, 'X' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) .AND. .NOT.NOTRNA ) THEN + INFO = -2 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE +C +C Compute workspace. +C + IF( ALL ) THEN + MINWRK = MAX( 4*N*N + 8*N + 1, 6*N*N ) + ELSE + MINWRK = 4*N*N + 8*N + 1 + END IF + IF( LDWORK.LT.MINWRK ) THEN + INFO = -19 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB02PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( ALL ) THEN + RCOND = ONE + FERR = ZERO + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Set tol. +C + EPS = DLAMCH( 'P' ) + TOL = TEN*DBLE( N )*EPS +C +C Compute the square-roots of the norms of the matrices Q and G . +C + QNORM2 = SQRT( DLANSY( '1', UPLO, N, Q, LDQ, DWORK ) ) + GNORM2 = SQRT( DLANSY( '1', UPLO, N, G, LDG, DWORK ) ) +C + N2 = 2*N +C +C Construct the lower (if UPLO = 'L') or upper (if UPLO = 'U') +C triangle of the symmetric block-permuted Hamiltonian matrix. +C During iteration, both the current iterate corresponding to the +C Hamiltonian matrix, and its inverse are needed. To reduce the +C workspace length, the transpose of the triangle specified by UPLO +C of the current iterate H is saved in the opposite triangle, +C suitably shifted with one column, and then the inverse of H +C overwrites H. The triangles of the saved iterate and its inverse +C are stored together in an 2*N-by-(2*N+1) matrix. For instance, if +C UPLO = 'U', then the upper triangle is built starting from the +C location 2*N+1 of the array DWORK, so that its transpose can be +C stored in the lower triangle of DWORK. +C Workspace: need 4*N*N, if UPLO = 'L'; +C 4*N*N + 2*N, if UPLO = 'U'. +C + IF ( LOWER ) THEN + INI = 0 + ISV = N2 + LOUP = 'U' +C + DO 40 J = 1, N + IJ = ( J - 1 )*N2 + J +C + DO 10 I = J, N + DWORK(IJ) = -Q(I,J) + IJ = IJ + 1 + 10 CONTINUE +C + IF( NOTRNA ) THEN +C + DO 20 I = 1, N + DWORK( IJ ) = -A( I, J ) + IJ = IJ + 1 + 20 CONTINUE +C + ELSE +C + DO 30 I = 1, N + DWORK( IJ ) = -A( J, I ) + IJ = IJ + 1 + 30 CONTINUE +C + END IF + 40 CONTINUE +C + DO 60 J = 1, N + IJ = ( N + J - 1 )*N2 + N + J +C + DO 50 I = J, N + DWORK( IJ ) = G( I, J ) + IJ = IJ + 1 + 50 CONTINUE +C + 60 CONTINUE +C + ELSE + INI = N2 + ISV = 0 + LOUP = 'L' +C + DO 80 J = 1, N + IJ = J*N2 + 1 +C + DO 70 I = 1, J + DWORK(IJ) = -Q(I,J) + IJ = IJ + 1 + 70 CONTINUE +C + 80 CONTINUE +C + DO 120 J = 1, N + IJ = ( N + J )*N2 + 1 +C + IF( NOTRNA ) THEN +C + DO 90 I = 1, N + DWORK( IJ ) = -A( J, I ) + IJ = IJ + 1 + 90 CONTINUE +C + ELSE +C + DO 100 I = 1, N + DWORK( IJ ) = -A( I, J ) + IJ = IJ + 1 + 100 CONTINUE +C + END IF +C + DO 110 I = 1, J + DWORK( IJ ) = G( I, J ) + IJ = IJ + 1 + 110 CONTINUE +C + 120 CONTINUE +C + END IF +C +C Block-scaling. +C + ISCL = 0 + IF( QNORM2.GT.GNORM2 .AND. GNORM2.GT.ZERO ) THEN + CALL DLASCL( UPLO, 0, 0, QNORM2, GNORM2, N, N, DWORK( INI+1 ), + $ N2, INFO2 ) + CALL DLASCL( UPLO, 0, 0, GNORM2, QNORM2, N, N, + $ DWORK( N2*N+N+INI+1 ), N2, INFO2 ) + ISCL = 1 + END IF +C +C Workspace usage. +C + ITAU = N2*N2 + IWRK = ITAU + N2 +C + LWAMAX = N2*ILAENV( 1, 'DSYTRF', UPLO, N2, -1, -1, -1 ) +C +C Compute the matrix sign function. +C + DO 230 ITER = 1, MAXIT +C +C Save the transpose of the corresponding triangle of the +C current iterate in the free locations of the shifted opposite +C triangle. +C Workspace: need 4*N*N + 2*N. +C + IF( LOWER ) THEN +C + DO 130 I = 1, N2 + CALL DCOPY( I, DWORK( I ), N2, DWORK( I*N2+1 ), 1 ) + 130 CONTINUE +C + ELSE +C + DO 140 I = 1, N2 + CALL DCOPY( I, DWORK( I*N2+1 ), 1, DWORK( I ), N2 ) + 140 CONTINUE +C + END IF +C +C Store the norm of the Hamiltonian matrix. +C + HNORM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) +C +C Compute the inverse of the block-permuted Hamiltonian matrix. +C Workspace: need 4*N*N + 2*N + 1; +C prefer 4*N*N + 2*N + 2*N*NB. +C + CALL DSYTRF( UPLO, N2, DWORK( INI+1 ), N2, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C +C Workspace: need 4*N*N + 4*N. +C + CALL DSYTRI( UPLO, N2, DWORK( INI+1 ), N2, IWORK, + $ DWORK( IWRK+1 ), INFO2 ) +C +C Block-permutation of the inverse matrix. +C + IF( LOWER ) THEN +C + DO 160 J = 1, N + IJ2 = ( N + J - 1 )*N2 + N + J +C + DO 150 IJ1 = ( J - 1 )*N2 + J, ( J - 1 )*N2 + N + TEMP = DWORK( IJ1 ) + DWORK( IJ1 ) = -DWORK( IJ2 ) + DWORK( IJ2 ) = -TEMP + IJ2 = IJ2 + 1 + 150 CONTINUE +C + CALL DSWAP( J-1, DWORK( N+J ), N2, DWORK( (J-1)*N2+N+1 ), + $ 1 ) + 160 CONTINUE +C + ELSE +C + DO 180 J = 1, N + IJ2 = ( N + J )*N2 + N + 1 +C + DO 170 IJ1 = J*N2 + 1, J*N2 + J + TEMP = DWORK( IJ1 ) + DWORK( IJ1 ) = -DWORK( IJ2 ) + DWORK( IJ2 ) = -TEMP + IJ2 = IJ2 + 1 + 170 CONTINUE +C + CALL DSWAP( J-1, DWORK( (N+1)*N2+J ), N2, + $ DWORK( (N+J)*N2+1 ), 1 ) + 180 CONTINUE +C + END IF +C +C Scale the Hamiltonian matrix and its inverse and compute +C the next iterate. +C + HINNRM = DLANSY( 'F', UPLO, N2, DWORK( INI+1 ), N2, DWORK ) + SCALE = SQRT( HINNRM / HNORM ) +C + IF( LOWER ) THEN +C + DO 200 J = 1, N2 + JI = ( J - 1 )*N2 + J +C + DO 190 IJ = JI, J*N2 + JI = JI + N2 + DWORK( IJ ) = ( DWORK( IJ ) / SCALE + + $ DWORK( JI )*SCALE ) / TWO + DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) + 190 CONTINUE +C + 200 CONTINUE +C + ELSE +C + DO 220 J = 1, N2 + JI = J +C + DO 210 IJ = J*N2 + 1, J*N2 + J + DWORK( IJ ) = ( DWORK( IJ ) / SCALE + + $ DWORK( JI )*SCALE ) / TWO + DWORK( JI ) = DWORK( JI ) - DWORK( IJ ) + JI = JI + N2 + 210 CONTINUE +C + 220 CONTINUE +C + END IF +C +C Test for convergence. +C + CONV = DLANSY( 'F', LOUP, N2, DWORK( ISV+1 ), N2, DWORK ) + IF( CONV.LE.TOL*HNORM ) GO TO 240 + 230 CONTINUE +C +C No convergence after MAXIT iterations, but an approximate solution +C has been found. +C + INFO = 2 +C + 240 CONTINUE +C +C If UPLO = 'U', shift the upper triangle one column to the left. +C + IF( .NOT.LOWER ) + $ CALL DLACPY( 'U', N2, N2, DWORK( INI+1 ), N2, DWORK, N2 ) +C +C Divide the triangle elements by -2 and then fill-in the other +C triangle by symmetry. +C + IF( LOWER ) THEN +C + DO 250 I = 1, N2 + CALL DSCAL( N2-I+1, -HALF, DWORK( (I-1)*N2+I ), 1 ) + 250 CONTINUE +C + ELSE +C + DO 260 I = 1, N2 + CALL DSCAL( I, -HALF, DWORK( (I-1)*N2+1 ), 1 ) + 260 CONTINUE +C + END IF + CALL MA02ED( UPLO, N2, DWORK, N2 ) +C +C Back block-permutation. +C + DO 280 J = 1, N2 +C + DO 270 I = ( J - 1 )*N2 + 1, ( J - 1 )*N2 + N + TEMP = DWORK( I ) + DWORK( I ) = -DWORK( I+N ) + DWORK( I+N ) = TEMP + 270 CONTINUE +C + 280 CONTINUE +C +C Compute the QR decomposition of the projector onto the stable +C invariant subspace. +C Workspace: need 4*N*N + 8*N + 1. +C prefer 4*N*N + 6*N + ( 2*N+1 )*NB. +C + DO 290 I = 1, N2 + IWORK( I ) = 0 + DWORK( ( I-1 )*N2 + I ) = DWORK( ( I-1 )*N2 + I ) + HALF + 290 CONTINUE +C + CALL DGEQP3( N2, N2, DWORK, N2, IWORK, DWORK( ITAU+1 ), + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) +C +C Accumulate the orthogonal transformations. Note that only the +C first N columns of the array DWORK, returned by DGEQP3, are +C needed, so that the last N columns of DWORK are used to get the +C orthogonal basis for the stable invariant subspace. +C Workspace: need 4*N*N + 3*N. +C prefer 4*N*N + 2*N + N*NB. +C + IB = N*N + IAF = N2*N + CALL DLASET( 'F', N2, N, ZERO, ONE, DWORK( IAF+1 ), N2 ) + CALL DORMQR( 'L', 'N', N2, N, N, DWORK, N2, DWORK( ITAU+1 ), + $ DWORK( IAF+1 ), N2, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) +C +C Store the matrices V11 and V21' . +C + CALL DLACPY( 'F', N, N, DWORK( IAF+1 ), N2, DWORK, N ) + CALL MA02AD( 'F', N, N, DWORK( IAF+N+1 ), N2, DWORK( IB+1 ), N ) +C + IR = IAF + IB + IC = IR + N + IFR = IC + N + IBR = IFR + N + IWRK = IBR + N +C +C Compute the solution matrix X . +C Workspace: need 3*N*N + 8*N. +C + CALL DGESVX( 'E', 'T', N, N, DWORK, N, DWORK( IAF+1 ), N, + $ IWORK, EQUED, DWORK( IR+1 ), DWORK( IC+1 ), + $ DWORK( IB+1 ), N, X, LDX, RCOND, DWORK( IFR+1 ), + $ DWORK( IBR+1 ), DWORK( IWRK+1 ), IWORK( N+1 ), + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF +C +C Symmetrize the solution. +C + DO 310 I = 1, N - 1 +C + DO 300 J = I + 1, N + TEMP = ( X( I, J ) + X( J, I ) ) / TWO + X( I, J ) = TEMP + X( J, I ) = TEMP + 300 CONTINUE +C + 310 CONTINUE +C +C Undo scaling for the solution matrix. +C + IF( ISCL.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, GNORM2, QNORM2, N, N, X, LDX, INFO2 ) + END IF +C + IF( ALL ) THEN +C +C Compute the estimates of the reciprocal condition number and +C error bound. +C Workspace usage. +C + IT = 1 + IU = IT + N*N + IWRK = IU + N*N +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IT+1 ), N ) + IF( NOTRNA ) THEN +C +C Compute Ac = A-G*X . +C + CALL DSYMM( 'L', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, + $ DWORK( IT+1 ), N ) + ELSE +C +C Compute Ac = A-X*G . +C + CALL DSYMM( 'R', UPLO, N, N, -ONE, G, LDG, X, LDX, ONE, + $ DWORK( IT+1 ), N ) + END IF +C +C Compute the Schur factorization of Ac . +C Workspace: need 2*N*N + 5*N + 1; +C prefer larger. +C + CALL DGEES( 'V', 'N', SELECT, N, DWORK( IT+1 ), N, SDIM, WR, + $ WI, DWORK( IU+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, + $ BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) +C +C Estimate the reciprocal condition number and the forward error. +C Workspace: need 6*N*N + 1; +C prefer larger. +C + CALL SB02QD( 'B', 'F', TRANA, UPLO, 'O', N, A, LDA, + $ DWORK( IT+1 ), N, DWORK( IU+1 ), N, G, LDG, Q, + $ LDQ, X, LDX, SEP, RCOND, FERR, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + LWAMAX = IWRK + MAX( INT( DWORK( IWRK+1 ) ), LWAMAX ) + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB02PD + END diff --git a/mex/sources/libslicot/SB02QD.f b/mex/sources/libslicot/SB02QD.f new file mode 100644 index 000000000..8ce39d1b3 --- /dev/null +++ b/mex/sources/libslicot/SB02QD.f @@ -0,0 +1,804 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02RD.f b/mex/sources/libslicot/SB02RD.f new file mode 100644 index 000000000..e4d14172f --- /dev/null +++ b/mex/sources/libslicot/SB02RD.f @@ -0,0 +1,1133 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02RU.f b/mex/sources/libslicot/SB02RU.f new file mode 100644 index 000000000..947d18148 --- /dev/null +++ b/mex/sources/libslicot/SB02RU.f @@ -0,0 +1,508 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB02SD.f b/mex/sources/libslicot/SB02SD.f new file mode 100644 index 000000000..81685c3b6 --- /dev/null +++ b/mex/sources/libslicot/SB02SD.f @@ -0,0 +1,859 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB03MD.f b/mex/sources/libslicot/SB03MD.f new file mode 100644 index 000000000..986998155 --- /dev/null +++ b/mex/sources/libslicot/SB03MD.f @@ -0,0 +1,556 @@ + SUBROUTINE SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU, C, + $ LDC, SCALE, SEP, FERR, WR, WI, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the real continuous-time Lyapunov equation +C +C op(A)'*X + X*op(A) = scale*C (1) +C +C or the real discrete-time Lyapunov equation +C +C op(A)'*X*op(A) - X = scale*C (2) +C +C and/or estimate an associated condition number, called separation, +C where op(A) = A or A' (A**T) and C is symmetric (C = C'). +C (A' denotes the transpose of the matrix A.) A is N-by-N, the right +C hand side C and the solution X are N-by-N, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the equation from which X is to be determined +C as follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'B': Compute both the solution and the separation. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix in Schur canonical form; +C the elements below the upper Hessenberg part of the +C array A are not referenced. +C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N +C upper Hessenberg part of this array contains the upper +C quasi-triangular matrix in Schur canonical form from the +C Schur factorization of A. The contents of array A is not +C modified if FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If FACT = 'F', then U is an input argument and on entry +C the leading N-by-N part of this array must contain the +C orthogonal matrix U of the real Schur factorization of A. +C If FACT = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO = N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with JOB = 'X' or 'B', the leading N-by-N part of +C this array must contain the symmetric matrix C. +C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, +C the leading N-by-N part of C has been overwritten by the +C symmetric solution matrix X. +C If JOB = 'S', C is not referenced. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP +C contains the estimated separation of the matrices op(A) +C and -op(A)', if DICO = 'C' or of op(A) and op(A)', if +C DICO = 'D'. +C If JOB = 'X' or N = 0, SEP is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains an +C estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the relative +C error in the computed solution, measured in the Frobenius +C norm: norm(X - XTRUE)/norm(XTRUE). +C If JOB = 'X' or JOB = 'S', FERR is not referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of +C the eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1, and +C If JOB = 'X' then +C If FACT = 'F', LDWORK >= N*N, for DICO = 'C'; +C LDWORK >= MAX(N*N, 2*N), for DICO = 'D'; +C If FACT = 'N', LDWORK >= MAX(N*N, 3*N). +C If JOB = 'S' or JOB = 'B' then +C If FACT = 'F', LDWORK >= 2*N*N, for DICO = 'C'; +C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. +C If FACT = 'N', LDWORK >= MAX(2*N*N, 3*N), DICO = 'C'; +C LDWORK >= 2*N*N + 2*N, for DICO = 'D'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues (see LAPACK Library routine DGEES); +C elements i+1:n of WR and WI contain eigenvalues +C which have converged, and A contains the partially +C converged Schur form; +C = N+1: if DICO = 'C', and the matrices A and -A' have +C common or very close eigenvalues, or +C if DICO = 'D', and matrix A has almost reciprocal +C eigenvalues (that is, lambda(i) = 1/lambda(j) for +C some i and j, where lambda(i) and lambda(j) are +C eigenvalues of A and i <> j); perturbed values were +C used to solve the equation (but the matrix A is +C unchanged). +C +C METHOD +C +C The Schur factorization of a square matrix A is given by +C +C A = U*S*U' +C +C where U is orthogonal and S is block upper triangular with 1-by-1 +C and 2-by-2 blocks on its diagonal, these blocks corresponding to +C the eigenvalues of A, the 2-by-2 blocks being complex conjugate +C pairs. This factorization is obtained by numerically stable +C methods: first A is reduced to upper Hessenberg form (if FACT = +C 'N') by means of Householder transformations and then the +C QR Algorithm is applied to reduce the Hessenberg form to S, the +C transformation matrices being accumulated at each step to give U. +C If A has already been factorized prior to calling the routine +C however, then the factors U and S may be supplied and the initial +C factorization omitted. +C _ _ +C If we now put C = U'CU and X = UXU' equations (1) and (2) (see +C PURPOSE) become (for TRANS = 'N') +C _ _ _ +C S'X + XS = C, (3) +C and +C _ _ _ +C S'XS - X = C, (4) +C +C respectively. Partition S, C and X as +C _ _ _ _ +C (s s') (c c') (x x') +C ( 11 ) _ ( 11 ) _ ( 11 ) +C S = ( ), C = ( ), X = ( ) +C ( ) ( _ ) ( _ ) +C ( 0 S ) ( c C ) ( x X ) +C 1 1 1 +C _ _ +C where s , c and x are either scalars or 2-by-2 matrices and s, +C 11 11 11 +C _ _ +C c and x are either (N-1) element vectors or matrices with two +C columns. Equations (3) and (4) can then be re-written as +C _ _ _ +C s' x + x s = c (3.1) +C 11 11 11 11 11 +C +C _ _ _ _ +C S'x + xs = c - sx (3.2) +C 1 11 11 +C +C _ _ +C S'X + X S = C - (sx' + xs') (3.3) +C 1 1 1 1 1 +C and +C _ _ _ +C s' x s - x = c (4.1) +C 11 11 11 11 11 +C +C _ _ _ _ +C S'xs - x = c - sx s (4.2) +C 1 11 11 11 +C +C _ _ _ +C S'X S - X = C - sx s' - [s(S'x)' + (S'x)s'] (4.3) +C 1 1 1 1 1 11 1 1 +C _ +C respectively. If DICO = 'C' ['D'], then once x has been +C 11 +C found from equation (3.1) [(4.1)], equation (3.2) [(4.2)] can be +C _ +C solved by forward substitution for x and then equation (3.3) +C [(4.3)] is of the same form as (3) [(4)] but of the order (N-1) or +C (N-2) depending upon whether s is 1-by-1 or 2-by-2. +C 11 +C _ _ +C When s is 2-by-2 then x and c will be 1-by-2 matrices and s, +C 11 11 11 +C _ _ +C x and c are matrices with two columns. In this case, equation +C (3.1) [(4.1)] defines the three equations in the unknown elements +C _ +C of x and equation (3.2) [(4.2)] can then be solved by forward +C 11 _ +C substitution, a row of x being found at each step. +C +C REFERENCES +C +C [1] Barraud, A.Y. T +C A numerical algorithm to solve A XA - X = Q. +C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. +C +C [2] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [3] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C If DICO = 'C', SEP is defined as the separation of op(A) and +C -op(A)': +C +C sep( op(A), -op(A)' ) = sigma_min( T ) +C +C and if DICO = 'D', SEP is defined as +C +C sep( op(A), op(A)' ) = sigma_min( T ) +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ) (DICO = 'C'), +C +C T = kprod( op(A)', op(A)' ) - I(N**2) (DICO = 'D'). +C +C I(x) is an x-by-x identity matrix, and kprod denotes the Kronecker +C product. The program estimates sigma_min(T) by the reciprocal of +C an estimate of the 1-norm of inverse(T). The true reciprocal +C 1-norm of inverse(T) cannot differ from sigma_min(T) by more +C than a factor of N. +C +C When SEP is small, small changes in A, C can cause large changes +C in the solution of the equation. An approximate bound on the +C maximum relative error in the computed solution is +C +C EPS * norm(A) / SEP (DICO = 'C'), +C +C EPS * norm(A)**2 / SEP (DICO = 'D'), +C +C where EPS is the machine precision. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, July 1997. +C Supersedes Release 2.0 routine SB03AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOB, TRANA + INTEGER INFO, LDA, LDC, LDU, LDWORK, N + DOUBLE PRECISION FERR, SCALE, SEP +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ U( LDU, * ), WI( * ), WR( * ) +C .. Local Scalars .. + LOGICAL CONT, NOFACT, NOTA, WANTBH, WANTSP, WANTX + CHARACTER NOTRA, NTRNST, TRANST, UPLO + INTEGER I, IERR, KASE, LWA, MINWRK, NN, NN2, SDIM + DOUBLE PRECISION EPS, EST, SCALEF +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, SB03MY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + CONT = LSAME( DICO, 'C' ) + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTA = LSAME( TRANA, 'N' ) + NN = N*N + NN2 = 2*NN +C + INFO = 0 + IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN + INFO = -2 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -3 + ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( WANTSP .AND. LDC.LT.1 .OR. + $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE + IF ( WANTX ) THEN + IF ( NOFACT ) THEN + MINWRK = MAX( NN, 3*N ) + ELSE IF ( CONT ) THEN + MINWRK = NN + ELSE + MINWRK = MAX( NN, 2*N ) + END IF + ELSE + IF ( CONT ) THEN + IF ( NOFACT ) THEN + MINWRK = MAX( NN2, 3*N ) + ELSE + MINWRK = NN2 + END IF + ELSE + MINWRK = NN2 + 2*N + END IF + END IF + IF( LDWORK.LT.MAX( 1, MINWRK ) ) + $ INFO = -19 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + SCALE = ONE + IF( WANTBH ) + $ FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + LWA = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LWA = INT( DWORK( 1 ) ) + END IF +C + IF( .NOT.WANTSP ) THEN +C +C Transform the right-hand side. +C Workspace: N*N. +C + NTRNST = 'N' + TRANST = 'T' + UPLO = 'U' + CALL MB01RD( UPLO, TRANST, N, N, ZERO, ONE, C, LDC, U, LDU, C, + $ LDC, DWORK, LDWORK, INFO ) +C + DO 10 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 10 CONTINUE +C + LWA = MAX( LWA, NN ) +C +C Solve the transformed equation. +C Workspace for DICO = 'D': 2*N. +C + IF ( CONT ) THEN + CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) + ELSE + CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) + END IF + IF( INFO.GT.0 ) + $ INFO = N + 1 +C +C Transform back the solution. +C Workspace: N*N. +C + CALL MB01RD( UPLO, NTRNST, N, N, ZERO, ONE, C, LDC, U, LDU, C, + $ LDC, DWORK, LDWORK, IERR ) +C + DO 20 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 20 CONTINUE +C + END IF +C + IF( .NOT.WANTX ) THEN +C +C Estimate the separation. +C Workspace: 2*N*N for DICO = 'C'; +C 2*N*N + 2*N for DICO = 'D'. +C + IF( NOTA ) THEN + NOTRA = 'T' + ELSE + NOTRA = 'N' + END IF +C + EST = ZERO + KASE = 0 +C REPEAT + 30 CONTINUE + CALL DLACON( NN, DWORK(NN+1), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + IF( CONT ) THEN + CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ IERR ) + ELSE + CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK(NN2+1), IERR ) + END IF + ELSE + IF( CONT ) THEN + CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ IERR ) + ELSE + CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK(NN2+1), IERR ) + END IF + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + SEP = SCALEF / EST +C + IF( WANTBH ) THEN +C +C Get the machine precision. +C + EPS = DLAMCH( 'P' ) +C +C Compute the estimate of the relative error. +C + IF ( CONT ) THEN + FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )/SEP + ELSE + FERR = EPS*DLANHS( 'Frobenius', N, A, LDA, DWORK )**2/SEP + END IF + END IF + END IF +C + DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) + RETURN +C *** Last line of SB03MD *** + END diff --git a/mex/sources/libslicot/SB03MU.f b/mex/sources/libslicot/SB03MU.f new file mode 100644 index 000000000..69ddd7429 --- /dev/null +++ b/mex/sources/libslicot/SB03MU.f @@ -0,0 +1,467 @@ + SUBROUTINE SB03MU( 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for the N1-by-N2 matrix X, 1 <= N1,N2 <= 2, in +C +C ISGN*op(TL)*X*op(TR) - X = SCALE*B, +C +C where TL is N1-by-N1, TR is N2-by-N2, B is N1-by-N2, and ISGN = 1 +C or -1. op(T) = T or T', where T' denotes the transpose of T. +C +C ARGUMENTS +C +C Mode Parameters +C +C LTRANL LOGICAL +C Specifies the form of op(TL) to be used, as follows: +C = .FALSE.: op(TL) = TL, +C = .TRUE. : op(TL) = TL'. +C +C LTRANR LOGICAL +C Specifies the form of op(TR) to be used, as follows: +C = .FALSE.: op(TR) = TR, +C = .TRUE. : op(TR) = TR'. +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C N1 (input) INTEGER +C The order of matrix TL. N1 may only be 0, 1 or 2. +C +C N2 (input) INTEGER +C The order of matrix TR. N2 may only be 0, 1 or 2. +C +C TL (input) DOUBLE PRECISION array, dimension (LDTL,2) +C The leading N1-by-N1 part of this array must contain the +C matrix TL. +C +C LDTL INTEGER +C The leading dimension of array TL. LDTL >= MAX(1,N1). +C +C TR (input) DOUBLE PRECISION array, dimension (LDTR,2) +C The leading N2-by-N2 part of this array must contain the +C matrix TR. +C +C LDTR INTEGER +C The leading dimension of array TR. LDTR >= MAX(1,N2). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,2) +C The leading N1-by-N2 part of this array must contain the +C right-hand side of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N1). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor. SCALE is chosen less than or equal to 1 +C to prevent the solution overflowing. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N2) +C The leading N1-by-N2 part of this array contains the +C solution of the equation. +C Note that X may be identified with B in the calling +C statement. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N1). +C +C XNORM (output) DOUBLE PRECISION +C The infinity-norm of the solution. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if TL and TR have almost reciprocal eigenvalues, so +C TL or TR is perturbed to get a nonsingular equation. +C +C NOTE: In the interests of speed, this routine does not +C check the inputs for errors. +C +C METHOD +C +C The equivalent linear algebraic system of equations is formed and +C solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Based on DLASD2 by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Discrete-time system, Sylvester equation, matrix algebra. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF, EIGHT + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 ) +C .. +C .. Scalar Arguments .. + LOGICAL LTRANL, LTRANR + INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 + DOUBLE PRECISION SCALE, XNORM +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL BSWAP, XSWAP + INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K + DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1, + $ TEMP, U11, U12, U22, XMAX +C .. +C .. Local Arrays .. + LOGICAL BSWPIV( 4 ), XSWPIV( 4 ) + INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ), + $ LOCU22( 4 ) + DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 ) +C .. +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. +C .. External Subroutines .. + EXTERNAL DSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Data statements .. + DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / , + $ LOCU22 / 4, 3, 2, 1 / + DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. / + DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. / +C .. +C .. Executable Statements .. +C +C Do not check the input parameters for errors. +C + INFO = 0 + SCALE = ONE +C +C Quick return if possible. +C + IF( N1.EQ.0 .OR. N2.EQ.0 ) THEN + XNORM = ZERO + RETURN + END IF +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) / EPS + SGN = ISGN +C + K = N1 + N1 + N2 - 2 + GO TO ( 10, 20, 30, 50 )K +C +C 1-by-1: SGN*TL11*X*TR11 - X = B11. +C + 10 CONTINUE + TAU1 = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE + BET = ABS( TAU1 ) + IF( BET.LE.SMLNUM ) THEN + TAU1 = SMLNUM + BET = SMLNUM + INFO = 1 + END IF +C + GAM = ABS( B( 1, 1 ) ) + IF( SMLNUM*GAM.GT.BET ) + $ SCALE = ONE / GAM +C + X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1 + XNORM = ABS( X( 1, 1 ) ) + RETURN +C +C 1-by-2: +C ISGN*TL11*[X11 X12]*op[TR11 TR12] = [B11 B12]. +C [TR21 TR22] +C + 20 CONTINUE +C + SMIN = MAX( MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + $ *ABS( TL( 1, 1 ) )*EPS, + $ SMLNUM ) + TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE + TMP( 4 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE + IF( LTRANR ) THEN + TMP( 2 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) + TMP( 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) + ELSE + TMP( 2 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) + TMP( 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 1, 2 ) + GO TO 40 +C +C 2-by-1: +C ISGN*op[TL11 TL12]*[X11]*TR11 = [B11]. +C [TL21 TL22] [X21] [B21] +C + 30 CONTINUE + SMIN = MAX( MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ) + $ *ABS( TR( 1, 1 ) )*EPS, + $ SMLNUM ) + TMP( 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE + TMP( 4 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE + IF( LTRANL ) THEN + TMP( 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) + TMP( 3 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) + ELSE + TMP( 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) + TMP( 3 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + 40 CONTINUE +C +C Solve 2-by-2 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + IPIV = IDAMAX( 4, TMP, 1 ) + U11 = TMP( IPIV ) + IF( ABS( U11 ).LE.SMIN ) THEN + INFO = 1 + U11 = SMIN + END IF + U12 = TMP( LOCU12( IPIV ) ) + L21 = TMP( LOCL21( IPIV ) ) / U11 + U22 = TMP( LOCU22( IPIV ) ) - U12*L21 + XSWAP = XSWPIV( IPIV ) + BSWAP = BSWPIV( IPIV ) + IF( ABS( U22 ).LE.SMIN ) THEN + INFO = 1 + U22 = SMIN + END IF + IF( BSWAP ) THEN + TEMP = BTMP( 2 ) + BTMP( 2 ) = BTMP( 1 ) - L21*TEMP + BTMP( 1 ) = TEMP + ELSE + BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 ) + END IF + IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR. + $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN + SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + END IF + X2( 2 ) = BTMP( 2 ) / U22 + X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 ) + IF( XSWAP ) THEN + TEMP = X2( 2 ) + X2( 2 ) = X2( 1 ) + X2( 1 ) = TEMP + END IF + X( 1, 1 ) = X2( 1 ) + IF( N1.EQ.1 ) THEN + X( 1, 2 ) = X2( 2 ) + XNORM = ABS( X2( 1 ) ) + ABS( X2( 2 ) ) + ELSE + X( 2, 1 ) = X2( 2 ) + XNORM = MAX( ABS( X2( 1 ) ), ABS( X2( 2 ) ) ) + END IF + RETURN +C +C 2-by-2: +C ISGN*op[TL11 TL12]*[X11 X12]*op[TR11 TR12]-[X11 X12] = [B11 B12]. +C [TL21 TL22] [X21 X22] [TR21 TR22] [X21 X22] [B21 B22] +C +C Solve equivalent 4-by-4 system using complete pivoting. +C Set pivots less than SMIN to SMIN. +C + 50 CONTINUE + SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ), + $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ) + SMIN = MAX( ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ), + $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )*SMIN + SMIN = MAX( EPS*SMIN, SMLNUM ) + T16( 1, 1 ) = SGN*TL( 1, 1 )*TR( 1, 1 ) - ONE + T16( 2, 2 ) = SGN*TL( 2, 2 )*TR( 1, 1 ) - ONE + T16( 3, 3 ) = SGN*TL( 1, 1 )*TR( 2, 2 ) - ONE + T16( 4, 4 ) = SGN*TL( 2, 2 )*TR( 2, 2 ) - ONE + IF( LTRANL ) THEN + T16( 1, 2 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) + T16( 2, 1 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) + T16( 3, 4 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) + T16( 4, 3 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) + ELSE + T16( 1, 2 ) = SGN*TL( 1, 2 )*TR( 1, 1 ) + T16( 2, 1 ) = SGN*TL( 2, 1 )*TR( 1, 1 ) + T16( 3, 4 ) = SGN*TL( 1, 2 )*TR( 2, 2 ) + T16( 4, 3 ) = SGN*TL( 2, 1 )*TR( 2, 2 ) + END IF + IF( LTRANR ) THEN + T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) + T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) + T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) + T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) + ELSE + T16( 1, 3 ) = SGN*TL( 1, 1 )*TR( 2, 1 ) + T16( 2, 4 ) = SGN*TL( 2, 2 )*TR( 2, 1 ) + T16( 3, 1 ) = SGN*TL( 1, 1 )*TR( 1, 2 ) + T16( 4, 2 ) = SGN*TL( 2, 2 )*TR( 1, 2 ) + END IF + IF( LTRANL .AND. LTRANR ) THEN + T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) + T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) + T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) + T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) + ELSE IF( LTRANL .AND. .NOT.LTRANR ) THEN + T16( 1, 4 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) + T16( 2, 3 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) + T16( 3, 2 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) + T16( 4, 1 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) + ELSE IF( .NOT.LTRANL .AND. LTRANR ) THEN + T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) + T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) + T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) + T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) + ELSE + T16( 1, 4 ) = SGN*TL( 1, 2 )*TR( 2, 1 ) + T16( 2, 3 ) = SGN*TL( 2, 1 )*TR( 2, 1 ) + T16( 3, 2 ) = SGN*TL( 1, 2 )*TR( 1, 2 ) + T16( 4, 1 ) = SGN*TL( 2, 1 )*TR( 1, 2 ) + END IF + BTMP( 1 ) = B( 1, 1 ) + BTMP( 2 ) = B( 2, 1 ) + BTMP( 3 ) = B( 1, 2 ) + BTMP( 4 ) = B( 2, 2 ) +C +C Perform elimination +C + DO 100 I = 1, 3 + XMAX = ZERO +C + DO 70 IP = I, 4 +C + DO 60 JP = I, 4 + IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN + XMAX = ABS( T16( IP, JP ) ) + IPSV = IP + JPSV = JP + END IF + 60 CONTINUE +C + 70 CONTINUE +C + IF( IPSV.NE.I ) THEN + CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 ) + TEMP = BTMP( I ) + BTMP( I ) = BTMP( IPSV ) + BTMP( IPSV ) = TEMP + END IF + IF( JPSV.NE.I ) + $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 ) + JPIV( I ) = JPSV + IF( ABS( T16( I, I ) ).LT.SMIN ) THEN + INFO = 1 + T16( I, I ) = SMIN + END IF +C + DO 90 J = I + 1, 4 + T16( J, I ) = T16( J, I ) / T16( I, I ) + BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I ) +C + DO 80 K = I + 1, 4 + T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K ) + 80 CONTINUE +C + 90 CONTINUE +C + 100 CONTINUE +C + IF( ABS( T16( 4, 4 ) ).LT.SMIN ) + $ T16( 4, 4 ) = SMIN + IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR. + $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN + SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ), + $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), + $ ABS( BTMP( 4 ) ) ) + BTMP( 1 ) = BTMP( 1 )*SCALE + BTMP( 2 ) = BTMP( 2 )*SCALE + BTMP( 3 ) = BTMP( 3 )*SCALE + BTMP( 4 ) = BTMP( 4 )*SCALE + END IF +C + DO 120 I = 1, 4 + K = 5 - I + TEMP = ONE / T16( K, K ) + TMP( K ) = BTMP( K )*TEMP +C + DO 110 J = K + 1, 4 + TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J ) + 110 CONTINUE +C + 120 CONTINUE +C + DO 130 I = 1, 3 + IF( JPIV( 4-I ).NE.4-I ) THEN + TEMP = TMP( 4-I ) + TMP( 4-I ) = TMP( JPIV( 4-I ) ) + TMP( JPIV( 4-I ) ) = TEMP + END IF + 130 CONTINUE +C + X( 1, 1 ) = TMP( 1 ) + X( 2, 1 ) = TMP( 2 ) + X( 1, 2 ) = TMP( 3 ) + X( 2, 2 ) = TMP( 4 ) + XNORM = MAX( ABS( TMP( 1 ) ) + ABS( TMP( 3 ) ), + $ ABS( TMP( 2 ) ) + ABS( TMP( 4 ) ) ) +C + RETURN +C *** Last line of SB03MU *** + END diff --git a/mex/sources/libslicot/SB03MV.f b/mex/sources/libslicot/SB03MV.f new file mode 100644 index 000000000..30dcc6af0 --- /dev/null +++ b/mex/sources/libslicot/SB03MV.f @@ -0,0 +1,295 @@ + SUBROUTINE SB03MV( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, + $ XNORM, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/SB03MW.f b/mex/sources/libslicot/SB03MW.f new file mode 100644 index 000000000..8a0a51202 --- /dev/null +++ b/mex/sources/libslicot/SB03MW.f @@ -0,0 +1,293 @@ + SUBROUTINE SB03MW( LTRAN, LUPPER, T, LDT, B, LDB, SCALE, X, LDX, + $ XNORM, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/SB03MX.f b/mex/sources/libslicot/SB03MX.f new file mode 100644 index 000000000..31b392998 --- /dev/null +++ b/mex/sources/libslicot/SB03MX.f @@ -0,0 +1,711 @@ + SUBROUTINE SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/SB03MY.f b/mex/sources/libslicot/SB03MY.f new file mode 100644 index 000000000..6aa1642cd --- /dev/null +++ b/mex/sources/libslicot/SB03MY.f @@ -0,0 +1,613 @@ + SUBROUTINE SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +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 diff --git a/mex/sources/libslicot/SB03OD.f b/mex/sources/libslicot/SB03OD.f new file mode 100644 index 000000000..0b93c7472 --- /dev/null +++ b/mex/sources/libslicot/SB03OD.f @@ -0,0 +1,662 @@ + SUBROUTINE SB03OD( DICO, FACT, TRANS, N, M, A, LDA, Q, LDQ, B, + $ LDB, SCALE, WR, WI, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X = op(U)'*op(U) either the stable non-negative +C definite continuous-time Lyapunov equation +C 2 +C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) +C +C or the convergent non-negative definite discrete-time Lyapunov +C equation +C 2 +C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), A is +C an N-by-N matrix, op(B) is an M-by-N matrix, U is an upper +C triangular matrix containing the Cholesky factor of the solution +C matrix X, X = op(U)'*op(U), and scale is an output scale factor, +C set less than or equal to 1 to avoid overflow in X. If matrix B +C has full rank then the solution matrix X will be positive-definite +C and hence the Cholesky factor U will be nonsingular, but if B is +C rank deficient then X may be only positive semi-definite and U +C will be singular. +C +C In the case of equation (1) the matrix A must be stable (that +C is, all the eigenvalues of A must have negative real parts), +C and for equation (2) the matrix A must be convergent (that is, +C all the eigenvalues of A must lie inside the unit circle). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of Lyapunov equation to be solved as +C follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and Q contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and Q. +C +C TRANS CHARACTER*1 +C Specifies the form of op(K) to be used, as follows: +C = 'N': op(K) = K (No transpose); +C = 'T': op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and the number of columns in +C matrix op(B). N >= 0. +C +C M (input) INTEGER +C The number of rows in matrix op(B). M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix S in Schur canonical +C form; the elements below the upper Hessenberg part of the +C array A are not referenced. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the upper quasi-triangular matrix S in +C Schur canonical form from the Shur factorization of A. +C The contents of array A is not modified if FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C Q (input or output) DOUBLE PRECISION array, dimension +C (LDQ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Q of the +C Schur factorization of A. +C Otherwise, Q need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Q of the Schur factorization of A. +C The contents of array Q is not modified if FACT = 'F'. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C if TRANS = 'N', and dimension (LDB,max(M,N)), if +C TRANS = 'T'. +C On entry, if TRANS = 'N', the leading M-by-N part of this +C array must contain the coefficient matrix B of the +C equation. +C On entry, if TRANS = 'T', the leading N-by-M part of this +C array must contain the coefficient matrix B of the +C equation. +C On exit, the leading N-by-N part of this array contains +C the upper triangular Cholesky factor U of the solution +C matrix X of the problem, X = op(U)'*op(U). +C If M = 0 and N > 0, then U is set to zero. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N,M), if TRANS = 'N'; +C LDB >= MAX(1,N), if TRANS = 'T'. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO >= 0 and INFO <= 2, WR and WI +C contain the real and imaginary parts, respectively, of +C the eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If M > 0, LDWORK >= MAX(1,4*N + MIN(M,N)); +C If M = 0, LDWORK >= 1. +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DICO = 'C' this means that while the matrix A +C (or the factor S) has computed eigenvalues with +C negative real parts, it is only just stable in the +C sense that small perturbations in A can make one or +C more of the eigenvalues have a non-negative real +C part; +C if DICO = 'D' this means that while the matrix A +C (or the factor S) has computed eigenvalues inside +C the unit circle, it is nevertheless only just +C convergent, in the sense that small perturbations +C in A can make one or more of the eigenvalues lie +C outside the unit circle; +C perturbed values were used to solve the equation; +C = 2: if FACT = 'N' and DICO = 'C', but the matrix A is +C not stable (that is, one or more of the eigenvalues +C of A has a non-negative real part), or DICO = 'D', +C but the matrix A is not convergent (that is, one or +C more of the eigenvalues of A lies outside the unit +C circle); however, A will still have been factored +C and the eigenvalues of A returned in WR and WI. +C = 3: if FACT = 'F' and DICO = 'C', but the Schur factor S +C supplied in the array A is not stable (that is, one +C or more of the eigenvalues of S has a non-negative +C real part), or DICO = 'D', but the Schur factor S +C supplied in the array A is not convergent (that is, +C one or more of the eigenvalues of S lies outside the +C unit circle); +C = 4: if FACT = 'F' and the Schur factor S supplied in +C the array A has two or more consecutive non-zero +C elements on the first sub-diagonal, so that there is +C a block larger than 2-by-2 on the diagonal; +C = 5: if FACT = 'F' and the Schur factor S supplied in +C the array A has a 2-by-2 diagonal block with real +C eigenvalues instead of a complex conjugate pair; +C = 6: if FACT = 'N' and the LAPACK Library routine DGEES +C has failed to converge. This failure is not likely +C to occur. The matrix B will be unaltered but A will +C be destroyed. +C +C METHOD +C +C The method used by the routine is based on the Bartels and Stewart +C method [1], except that it finds the upper triangular matrix U +C directly without first finding X and without the need to form the +C normal matrix op(B)'*op(B). +C +C The Schur factorization of a square matrix A is given by +C +C A = QSQ', +C +C where Q is orthogonal and S is an N-by-N block upper triangular +C matrix with 1-by-1 and 2-by-2 blocks on its diagonal (which +C correspond to the eigenvalues of A). If A has already been +C factored prior to calling the routine however, then the factors +C Q and S may be supplied and the initial factorization omitted. +C +C If TRANS = 'N', the matrix B is factored as (QR factorization) +C _ _ _ _ _ +C B = P ( R ), M >= N, B = P ( R Z ), M < N, +C ( 0 ) +C _ _ +C where P is an M-by-M orthogonal matrix and R is a square upper +C _ _ _ _ _ +C triangular matrix. Then, the matrix B = RQ, or B = ( R Z )Q (if +C M < N) is factored as +C _ _ +C B = P ( R ), M >= N, B = P ( R Z ), M < N. +C +C If TRANS = 'T', the matrix B is factored as (RQ factorization) +C _ +C _ _ ( Z ) _ +C B = ( 0 R ) P, M >= N, B = ( _ ) P, M < N, +C ( R ) +C _ _ +C where P is an M-by-M orthogonal matrix and R is a square upper +C _ _ _ _ _ +C triangular matrix. Then, the matrix B = Q'R, or B = Q'( Z' R' )' +C (if M < N) is factored as +C _ _ +C B = ( R ) P, M >= N, B = ( Z ) P, M < N. +C ( R ) +C +C These factorizations are utilised to either transform the +C continuous-time Lyapunov equation to the canonical form +C 2 +C op(S)'*op(V)'*op(V) + op(V)'*op(V)*op(S) = -scale *op(F)'*op(F), +C +C or the discrete-time Lyapunov equation to the canonical form +C 2 +C op(S)'*op(V)'*op(V)*op(S) - op(V)'*op(V) = -scale *op(F)'*op(F), +C +C where V and F are upper triangular, and +C +C F = R, M >= N, F = ( R Z ), M < N, if TRANS = 'N'; +C ( 0 0 ) +C +C F = R, M >= N, F = ( 0 Z ), M < N, if TRANS = 'T'. +C ( 0 R ) +C +C The transformed equation is then solved for V, from which U is +C obtained via the QR factorization of V*Q', if TRANS = 'N', or +C via the RQ factorization of Q*V, if TRANS = 'T'. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. +C Solution of the matrix equation A'X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if A is only just stable (or convergent) then the Lyapunov +C equation will be ill-conditioned. A symptom of ill-conditioning +C is "large" elements in U relative to those of A and B, or a +C "small" value for scale. A condition estimate can be computed +C using SLICOT Library routine SB03MD. +C +C SB03OD routine can be also used for solving "unstable" Lyapunov +C equations, i.e., when matrix A has all eigenvalues with positive +C real parts, if DICO = 'C', or with moduli greater than one, +C if DICO = 'D'. Specifically, one may solve for X = op(U)'*op(U) +C either the continuous-time Lyapunov equation +C 2 +C op(A)'*X + X*op(A) = scale *op(B)'*op(B), (3) +C +C or the discrete-time Lyapunov equation +C 2 +C op(A)'*X*op(A) - X = scale *op(B)'*op(B), (4) +C +C provided, for equation (3), the given matrix A is replaced by -A, +C or, for equation (4), the given matrices A and B are replaced by +C inv(A) and B*inv(A), if TRANS = 'N' (or inv(A)*B, if TRANS = 'T'), +C respectively. Although the inversion generally can rise numerical +C problems, in case of equation (4) it is expected that the matrix A +C is enough well-conditioned, having only eigenvalues with moduli +C greater than 1. However, if A is ill-conditioned, it could be +C preferable to use the more general SLICOT Lyapunov solver SB03MD. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB03CD by Sven Hammarling, +C NAG Ltd, United Kingdom. +C +C REVISIONS +C +C Dec. 1997, April 1998, May 1998, May 1999, Oct. 2001 (V. Sima). +C March 2002 (A. Varga). +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, TRANS + INTEGER INFO, LDA, LDB, LDQ, LDWORK, M, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), Q(LDQ,*), WI(*), + $ WR(*) +C .. Local Scalars .. + LOGICAL CONT, LTRANS, NOFACT + INTEGER I, IFAIL, INFORM, ITAU, J, JWORK, K, L, MINMN, + $ NE, SDIM, WRKOPT + DOUBLE PRECISION EMAX, TEMP +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAPY2 + EXTERNAL DLAPY2, LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DGEQRF, DGERQF, + $ DLACPY, DLASET, DTRMM, SB03OU, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C +C Test the input scalar arguments. +C + CONT = LSAME( DICO, 'C' ) + NOFACT = LSAME( FACT, 'N' ) + LTRANS = LSAME( TRANS, 'T' ) + MINMN = MIN( M, N ) +C + INFO = 0 + IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LTRANS .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( ( LDB.LT.MAX( 1, N ) ) .OR. + $ ( LDB.LT.MAX( 1, N, M ) .AND. .NOT.LTRANS ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.1 .OR. ( M.GT.0 .AND. LDWORK.LT.4*N + MINMN ) ) + $ THEN + INFO = -16 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MINMN.EQ.0 ) THEN + IF( M.EQ.0 ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) + SCALE = ONE + DWORK(1) = ONE + RETURN + END IF +C +C Start the solution. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( NOFACT ) THEN +C +C Find the Schur factorization of A, A = Q*S*Q'. +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, Q, LDQ, DWORK, LDWORK, BWORK, INFORM ) + IF ( INFORM.NE.0 ) THEN + INFO = 6 + RETURN + END IF + WRKOPT = DWORK(1) +C +C Check the eigenvalues for stability. +C + IF ( CONT ) THEN + EMAX = WR(1) +C + DO 20 J = 2, N + IF ( WR(J).GT.EMAX ) + $ EMAX = WR(J) + 20 CONTINUE +C + ELSE + EMAX = DLAPY2( WR(1), WI(1) ) +C + DO 40 J = 2, N + TEMP = DLAPY2( WR(J), WI(J) ) + IF ( TEMP.GT.EMAX ) + $ EMAX = TEMP + 40 CONTINUE +C + END IF +C + IF ( ( CONT ) .AND. ( EMAX.GE.ZERO ) .OR. + $ ( .NOT.CONT ) .AND. ( EMAX.GE.ONE ) ) THEN + INFO = 2 + RETURN + END IF + ELSE + WRKOPT = 0 + END IF +C +C Perform the QR or RQ factorization of B, +C _ _ _ _ _ +C B = P ( R ), or B = P ( R Z ), if TRANS = 'N', or +C ( 0 ) +C _ +C _ _ ( Z ) _ +C B = ( 0 R ) P, or B = ( _ ) P, if TRANS = 'T'. +C ( R ) +C Workspace: need MIN(M,N) + N; +C prefer MIN(M,N) + N*NB. +C + ITAU = 1 + JWORK = ITAU + MINMN + IF ( LTRANS ) THEN + CALL DGERQF( N, M, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N) + JWORK = ITAU +C +C Form in B +C _ _ _ _ _ _ +C B := Q'R, m >= n, B := Q'*( Z' R' )', m < n, with B an +C n-by-min(m,n) matrix. +C Use a BLAS 3 operation if enough workspace, and BLAS 2, +C _ +C otherwise: B is formed column by column. +C + IF ( LDWORK.GE.JWORK+MINMN*N-1 ) THEN + K = JWORK +C + DO 60 I = 1, MINMN + CALL DCOPY( N, Q(N-MINMN+I,1), LDQ, DWORK(K), 1 ) + K = K + N + 60 CONTINUE +C + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non-unit', + $ N, MINMN, ONE, B(N-MINMN+1,M-MINMN+1), LDB, + $ DWORK(JWORK), N ) + IF ( M.LT.N ) + $ CALL DGEMM( 'Transpose', 'No transpose', N, M, N-M, + $ ONE, Q, LDQ, B, LDB, ONE, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, MINMN, DWORK(JWORK), N, B, LDB ) + ELSE + NE = N - MINMN +C + DO 80 J = 1, MINMN + NE = NE + 1 + CALL DCOPY( NE, B(1,M-MINMN+J), 1, DWORK(JWORK), 1 ) + CALL DGEMV( 'Transpose', NE, N, ONE, Q, LDQ, + $ DWORK(JWORK), 1, ZERO, B(1,J), 1 ) + 80 CONTINUE +C + END IF + ELSE + CALL DGEQRF( M, N, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1, MINMN*N) + JWORK = ITAU +C +C Form in B +C _ _ _ _ _ _ +C B := RQ, m >= n, B := ( R Z )*Q, m < n, with B an +C min(m,n)-by-n matrix. +C Use a BLAS 3 operation if enough workspace, and BLAS 2, +C _ +C otherwise: B is formed row by row. +C + IF ( LDWORK.GE.JWORK+MINMN*N-1 ) THEN + CALL DLACPY( 'Full', MINMN, N, Q, LDQ, DWORK(JWORK), MINMN ) + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', + $ MINMN, N, ONE, B, LDB, DWORK(JWORK), MINMN ) + IF ( M.LT.N ) + $ CALL DGEMM( 'No transpose', 'No transpose', M, N, N-M, + $ ONE, B(1,M+1), LDB, Q(M+1,1), LDQ, ONE, + $ DWORK(JWORK), MINMN ) + CALL DLACPY( 'Full', MINMN, N, DWORK(JWORK), MINMN, B, LDB ) + ELSE + NE = MINMN + MAX( 0, N-M ) +C + DO 100 J = 1, MINMN + CALL DCOPY( NE, B(J,J), LDB, DWORK(JWORK), 1 ) + CALL DGEMV( 'Transpose', NE, N, ONE, Q(J,1), LDQ, + $ DWORK(JWORK), 1, ZERO, B(J,1), LDB ) + NE = NE - 1 + 100 CONTINUE +C + END IF + END IF + JWORK = ITAU + MINMN +C +C Solve for U the transformed Lyapunov equation +C 2 _ _ +C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(B)'*op(B), +C +C or +C 2 _ _ +C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(B)'*op(B) +C +C Workspace: need MIN(M,N) + 4*N; +C prefer larger. +C + CALL SB03OU( .NOT.CONT, LTRANS, N, MINMN, A, LDA, B, LDB, + $ DWORK(ITAU), B, LDB, SCALE, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + IF ( INFO.GT.1 ) THEN + INFO = INFO + 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = ITAU +C +C Form U := U*Q' or U := Q*U in the array B. +C Use a BLAS 3 operation if enough workspace, and BLAS 2, otherwise. +C Workspace: need N; +C prefer N*N; +C + IF ( LDWORK.GE.JWORK+N*N-1 ) THEN + IF ( LTRANS ) THEN + CALL DLACPY( 'Full', N, N, Q, LDQ, DWORK(JWORK), N ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, + $ N, ONE, B, LDB, DWORK(JWORK), N ) + ELSE + K = JWORK +C + DO 120 I = 1, N + CALL DCOPY( N, Q(1,I), 1, DWORK(K), N ) + K = K + 1 + 120 CONTINUE +C + CALL DTRMM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ N, ONE, B, LDB, DWORK(JWORK), N ) + END IF + CALL DLACPY( 'Full', N, N, DWORK(JWORK), N, B, LDB ) + WRKOPT = MAX( WRKOPT, JWORK + N*N - 1 ) + ELSE + IF ( LTRANS ) THEN +C +C U is formed column by column ( U := Q*U ). +C + DO 140 I = 1, N + CALL DCOPY( I, B(1,I), 1, DWORK(JWORK), 1 ) + CALL DGEMV( 'No transpose', N, I, ONE, Q, LDQ, + $ DWORK(JWORK), 1, ZERO, B(1,I), 1 ) + 140 CONTINUE + ELSE +C +C U is formed row by row ( U' := Q*U' ). +C + DO 160 I = 1, N + CALL DCOPY( N-I+1, B(I,I), LDB, DWORK(JWORK), 1 ) + CALL DGEMV( 'No transpose', N, N-I+1, ONE, Q(1,I), LDQ, + $ DWORK(JWORK), 1, ZERO, B(I,1), LDB ) + 160 CONTINUE + END IF + END IF +C +C Lastly find the QR or RQ factorization of U, overwriting on B, +C to give the required Cholesky factor. +C Workspace: need 2*N; +C prefer N + N*NB; +C + JWORK = ITAU + N + IF ( LTRANS ) THEN + CALL DGERQF( N, N, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + ELSE + CALL DGEQRF( N, N, B, LDB, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Make the diagonal elements of U non-negative. +C + IF ( LTRANS ) THEN +C + DO 200 J = 1, N + IF ( B(J,J).LT.ZERO ) THEN +C + DO 180 I = 1, J + B(I,J) = -B(I,J) + 180 CONTINUE +C + END IF + 200 CONTINUE +C + ELSE + K = JWORK +C + DO 240 J = 1, N + DWORK(K) = B(J,J) + L = JWORK +C + DO 220 I = 1, J + IF ( DWORK(L).LT.ZERO ) B(I,J) = -B(I,J) + L = L + 1 + 220 CONTINUE +C + K = K + 1 + 240 CONTINUE + END IF +C + IF( N.GT.1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) +C +C Set the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB03OD *** + END diff --git a/mex/sources/libslicot/SB03OR.f b/mex/sources/libslicot/SB03OR.f new file mode 100644 index 000000000..1094f26f5 --- /dev/null +++ b/mex/sources/libslicot/SB03OR.f @@ -0,0 +1,429 @@ + SUBROUTINE SB03OR( DISCR, LTRANS, N, M, S, LDS, A, LDA, C, LDC, + $ SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the solution of the Sylvester equations +C +C op(S)'*X + X*op(A) = scale*C, if DISCR = .FALSE. or +C +C op(S)'*X*op(A) - X = scale*C, if DISCR = .TRUE. +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), S is +C an N-by-N block upper triangular matrix with one-by-one and +C two-by-two blocks on the diagonal, A is an M-by-M matrix (M = 1 or +C M = 2), X and C are each N-by-M matrices, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C The solution X is overwritten on C. +C +C SB03OR is a service routine for the Lyapunov solver SB03OT. +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the equation to be solved: +C = .FALSE.: op(S)'*X + X*op(A) = scale*C; +C = .TRUE. : op(S)'*X*op(A) - X = scale*C. +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix S and also the number of rows of +C matrices X and C. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A and also the number of columns +C of matrices X and C. M = 1 or M = 2. +C +C S (input) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper Hessenberg part of the array S +C must contain the block upper triangular matrix. The +C elements below the upper Hessenberg part of the array S +C are not referenced. The array S must not contain +C diagonal blocks larger than two-by-two and the two-by-two +C blocks must only correspond to complex conjugate pairs of +C eigenvalues, not to real eigenvalues. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C A (input) DOUBLE PRECISION array, dimension (LDS,M) +C The leading M-by-M part of this array must contain a +C given matrix, where M = 1 or M = 2. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= M. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, C must contain an N-by-M matrix, where M = 1 or +C M = 2. +C On exit, C contains the N-by-M matrix X, the solution of +C the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if DISCR = .FALSE., and S and -A have common +C eigenvalues, or if DISCR = .TRUE., and S and A have +C eigenvalues whose product is equal to unity; +C a solution has been computed using slightly +C perturbed values. +C +C METHOD +C +C The LAPACK scheme for solving Sylvester equations is adapted. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 2 +C The algorithm requires 0(N M) operations and is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routines SB03CW and SB03CX by +C Sven Hammarling, NAG Ltd, United Kingdom, Oct. 1986. +C Partly based on routine PLYAP4 by A. Varga, University of Bochum, +C May 1992. +C +C REVISIONS +C +C December 1997, April 1998, May 1999, April 2000. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, LDA, LDS, LDC, M, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), S( LDS, * ) +C .. Local Scalars .. + LOGICAL TBYT + INTEGER DL, INFOM, ISGN, J, L, L1, L2, L2P1, LNEXT + DOUBLE PRECISION G11, G12, G21, G22, SCALOC, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION AT( 2, 2 ), VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. +C .. External Subroutines .. + EXTERNAL DLASY2, DSCAL, SB04PX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( .NOT.( M.EQ.1 .OR. M.EQ.2 ) ) THEN + INFO = -4 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.M ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OR', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N.EQ.0 ) + $ RETURN +C + ISGN = 1 + TBYT = M.EQ.2 + INFOM = 0 +C +C Construct A'. +C + AT(1,1) = A(1,1) + IF ( TBYT ) THEN + AT(1,2) = A(2,1) + AT(2,1) = A(1,2) + AT(2,2) = A(2,2) + END IF +C + IF ( LTRANS ) THEN +C +C Start row loop (index = L). +C L1 (L2) : row index of the first (last) row of X(L). +C + LNEXT = N +C + DO 20 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 20 + L1 = L + L2 = L + IF( L.GT.1 ) THEN + IF( S( L, L-1 ).NE.ZERO ) + $ L1 = L1 - 1 + LNEXT = L1 - 1 + END IF + DL = L2 - L1 + 1 + L2P1 = MIN( L2+1, N ) +C + IF ( DISCR ) THEN +C +C Solve S*X*A' - X = scale*C. +C +C The L-th block of X is determined from +C +C S(L,L)*X(L)*A' - X(L) = C(L) - R(L), +C +C where +C +C N +C R(L) = SUM [S(L,J)*X(J)] * A' . +C J=L+1 +C + G11 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 1 ), 1 ) + IF ( TBYT ) THEN + G12 = -DDOT( N-L2, S( L1, L2P1 ), LDS, C( L2P1, 2 ), + $ 1 ) + VEC( 1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + G12*AT(2,1) + VEC( 1, 2 ) = C( L1, 2 ) + G11*AT(1,2) + G12*AT(2,2) + ELSE + VEC (1, 1 ) = C( L1, 1 ) + G11*AT(1,1) + END IF + IF ( DL.NE.1 ) THEN + G21 = -DDOT( N-L2, S( L2, L2P1 ), LDS, C( L2P1, 1 ), + $ 1 ) + IF ( TBYT ) THEN + G22 = -DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) + VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + + $ G22*AT(2,1) + VEC( 2, 2 ) = C( L2, 2 ) + G21*AT(1,2) + + $ G22*AT(2,2) + ELSE + VEC( 2, 1 ) = C( L2, 1 ) + G21*AT(1,1) + END IF + END IF + CALL SB04PX( .FALSE., .FALSE., -ISGN, DL, M, S( L1, L1 ), + $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, + $ INFO ) + ELSE +C +C Solve S*X + X*A' = scale*C. +C +C The L-th block of X is determined from +C +C S(L,L)*X(L) + X(L)*A' = C(L) - R(L), +C +C where +C N +C R(L) = SUM S(L,J)*X(J) . +C J=L+1 +C + VEC( 1, 1 ) = C( L1, 1 ) - + $ DDOT( N-L2, S( L1, L2P1 ), LDS, + $ C( L2P1, 1 ), 1 ) + IF ( TBYT ) + $ VEC( 1, 2 ) = C( L1, 2 ) - + $ DDOT( N-L2, S( L1, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) +C + IF ( DL.NE.1 ) THEN + VEC( 2, 1 ) = C( L2, 1 ) - + $ DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 1 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 2 ) = C( L2, 2 ) - + $ DDOT( N-L2, S( L2, L2P1 ), LDS, + $ C( L2P1, 2 ), 1 ) + END IF + CALL DLASY2( .FALSE., .FALSE., ISGN, DL, M, S( L1, L1 ), + $ LDS, AT, 2, VEC, 2, SCALOC, X, 2, XNORM, + $ INFO ) + END IF + INFOM = MAX( INFO, INFOM ) + IF ( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, M + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( L1, 1 ) = X( 1, 1 ) + IF ( TBYT ) C( L1, 2 ) = X( 1, 2 ) + IF ( DL.NE.1 ) THEN + C( L2, 1 ) = X( 2, 1 ) + IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) + END IF + 20 CONTINUE +C + ELSE +C +C Start row loop (index = L). +C L1 (L2) : row index of the first (last) row of X(L). +C + LNEXT = 1 +C + DO 40 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 40 + L1 = L + L2 = L + IF( L.LT.N ) THEN + IF( S( L+1, L ).NE.ZERO ) + $ L2 = L2 + 1 + LNEXT = L2 + 1 + END IF + DL = L2 - L1 + 1 +C + IF ( DISCR ) THEN +C +C Solve A'*X'*S - X' = scale*C'. +C +C The L-th block of X is determined from +C +C A'*X(L)'*S(L,L) - X(L)' = C(L)' - R(L), +C +C where +C +C L-1 +C R(L) = A' * SUM [X(J)'*S(J,L)] . +C J=1 +C + G11 = -DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) + IF ( TBYT ) THEN + G21 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1 ) + VEC( 1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + AT(1,2)*G21 + VEC( 2, 1 ) = C( L1, 2 ) + AT(2,1)*G11 + AT(2,2)*G21 + ELSE + VEC (1, 1 ) = C( L1, 1 ) + AT(1,1)*G11 + END IF + IF ( DL .NE. 1 ) THEN + G12 = -DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) + IF ( TBYT ) THEN + G22 = -DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1 ) + VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + + $ AT(1,2)*G22 + VEC( 2, 2 ) = C( L2, 2 ) + AT(2,1)*G12 + + $ AT(2,2)*G22 + ELSE + VEC( 1, 2 ) = C( L2, 1 ) + AT(1,1)*G12 + END IF + END IF + CALL SB04PX( .FALSE., .FALSE., -ISGN, M, DL, AT, 2, + $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, + $ XNORM, INFO ) + ELSE +C +C Solve A'*X' + X'*S = scale*C'. +C +C The L-th block of X is determined from +C +C A'*X(L)' + X(L)'*S(L,L) = C(L)' - R(L), +C +C where +C L-1 +C R(L) = SUM [X(J)'*S(J,L)]. +C J=1 +C + VEC( 1, 1 ) = C( L1, 1 ) - + $ DDOT( L1-1, C, 1, S( 1, L1 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 1 ) = C( L1, 2 ) - + $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L1 ), 1) +C + IF ( DL.NE.1 ) THEN + VEC( 1, 2 ) = C( L2, 1 ) - + $ DDOT( L1-1, C, 1, S( 1, L2 ), 1 ) + IF ( TBYT ) + $ VEC( 2, 2 ) = C( L2, 2 ) - + $ DDOT( L1-1, C( 1, 2 ), 1, S( 1, L2 ), 1) + END IF + CALL DLASY2( .FALSE., .FALSE., ISGN, M, DL, AT, 2, + $ S( L1, L1 ), LDS, VEC, 2, SCALOC, X, 2, + $ XNORM, INFO ) + END IF + INFOM = MAX( INFO, INFOM ) + IF ( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, M + CALL DSCAL( N, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + C( L1, 1 ) = X( 1, 1 ) + IF ( TBYT ) C( L1, 2 ) = X( 2, 1 ) + IF ( DL.NE.1 ) THEN + C( L2, 1 ) = X( 1, 2 ) + IF ( TBYT ) C( L2, 2 ) = X( 2, 2 ) + END IF + 40 CONTINUE + END IF +C + INFO = INFOM + RETURN +C *** Last line of SB03OR *** + END diff --git a/mex/sources/libslicot/SB03OT.f b/mex/sources/libslicot/SB03OT.f new file mode 100644 index 000000000..92550bf56 --- /dev/null +++ b/mex/sources/libslicot/SB03OT.f @@ -0,0 +1,984 @@ + SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X = op(U)'*op(U) either the stable non-negative +C definite continuous-time Lyapunov equation +C 2 +C op(S)'*X + X*op(S) = -scale *op(R)'*op(R) (1) +C +C or the convergent non-negative definite discrete-time Lyapunov +C equation +C 2 +C op(S)'*X*op(S) - X = -scale *op(R)'*op(R) (2) +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), S is +C an N-by-N block upper triangular matrix with one-by-one or +C two-by-two blocks on the diagonal, R is an N-by-N upper triangular +C matrix, and scale is an output scale factor, set less than or +C equal to 1 to avoid overflow in X. +C +C In the case of equation (1) the matrix S must be stable (that +C is, all the eigenvalues of S must have negative real parts), +C and for equation (2) the matrix S must be convergent (that is, +C all the eigenvalues of S must lie inside the unit circle). +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the type of Lyapunov equation to be solved as +C follows: +C = .TRUE. : Equation (2), discrete-time case; +C = .FALSE.: Equation (1), continuous-time case. +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices S and R. N >= 0. +C +C S (input) DOUBLE PRECISION array of dimension (LDS,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the block upper triangular matrix. +C The elements below the upper Hessenberg part of the array +C S are not referenced. The 2-by-2 blocks must only +C correspond to complex conjugate pairs of eigenvalues (not +C to real eigenvalues). +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N). +C +C R (input/output) DOUBLE PRECISION array of dimension (LDR,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the upper triangular matrix R. +C On exit, the leading N-by-N upper triangular part of this +C array contains the upper triangular matrix U. +C The strict lower triangle of R is not referenced. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (4*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DISCR = .FALSE., this means that while the +C matrix S has computed eigenvalues with negative real +C parts, it is only just stable in the sense that +C small perturbations in S can make one or more of the +C eigenvalues have a non-negative real part; +C if DISCR = .TRUE., this means that while the +C matrix S has computed eigenvalues inside the unit +C circle, it is nevertheless only just convergent, in +C the sense that small perturbations in S can make one +C or more of the eigenvalues lie outside the unit +C circle; +C perturbed values were used to solve the equation +C (but the matrix S is unchanged); +C = 2: if the matrix S is not stable (that is, one or more +C of the eigenvalues of S has a non-negative real +C part), if DISCR = .FALSE., or not convergent (that +C is, one or more of the eigenvalues of S lies outside +C the unit circle), if DISCR = .TRUE.; +C = 3: if the matrix S has two or more consecutive non-zero +C elements on the first sub-diagonal, so that there is +C a block larger than 2-by-2 on the diagonal; +C = 4: if the matrix S has a 2-by-2 diagonal block with +C real eigenvalues instead of a complex conjugate +C pair. +C +C METHOD +C +C The method used by the routine is based on a variant of the +C Bartels and Stewart backward substitution method [1], that finds +C the Cholesky factor op(U) directly without first finding X and +C without the need to form the normal matrix op(R)'*op(R) [2]. +C +C The continuous-time Lyapunov equation in the canonical form +C 2 +C op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(R)'*op(R), +C +C or the discrete-time Lyapunov equation in the canonical form +C 2 +C op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(R)'*op(R), +C +C where U and R are upper triangular, is solved for U. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. +C Solution of the matrix equation A'X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular +C if S is only just stable (or convergent) then the Lyapunov +C equation will be ill-conditioned. "Large" elements in U relative +C to those of S and R, or a "small" value for scale, is a symptom +C of ill-conditioning. A condition estimate can be computed using +C SLICOT Library routine SB03MD. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, +C NAG Ltd, United Kingdom, Oct. 1986. +C Partly based on SB03CZ and PLYAP1 by A. Varga, University of +C Bochum, May 1992. +C +C REVISIONS +C +C Dec. 1997, April 1998, May 1999, Feb. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, LDR, LDS, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL CONT, TBYT + INTEGER INFOM, ISGN, J, J1, J2, J3, K, K1, K2, K3, + $ KOUNT, KSIZE + DOUBLE PRECISION ABSSKK, ALPHA, BIGNUM, D1, D2, DR, EPS, SCALOC, + $ SMIN, SMLNUM, SUM, T1, T2, T3, T4, TAU1, TAU2, + $ TEMP, V1, V2, V3, V4 +C .. Local Arrays .. + DOUBLE PRECISION A(2,2), B(2,2), U(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLABAD, DLARFG, DSCAL, DSWAP, + $ DTRMM, DTRMV, MB04ND, MB04OD, SB03OR, SB03OY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OT', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF (N.EQ.0) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( N*N ) / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, S, LDS, DWORK ) ) + INFOM = 0 +C +C Start the solution. Most of the comments refer to notation and +C equations in sections 5 and 10 of the second reference above. +C +C Determine whether or not the current block is two-by-two. +C K gives the position of the start of the current block and +C TBYT is true if the block is two-by-two. +C + CONT = .NOT.DISCR + ISGN = 1 + IF ( .NOT.LTRANS ) THEN +C +C Case op(M) = M. +C + KOUNT = 1 +C + 10 CONTINUE +C WHILE( KOUNT.LE.N )LOOP + IF ( KOUNT.LE.N ) THEN + K = KOUNT + IF ( KOUNT.GE.N ) THEN + TBYT = .FALSE. + KOUNT = KOUNT + 1 + ELSE IF ( S(K+1,K).EQ.ZERO ) THEN + TBYT = .FALSE. + KOUNT = KOUNT + 1 + ELSE + TBYT = .TRUE. + IF ( (K+1).LT.N ) THEN + IF ( S(K+2,K+1).NE.ZERO ) THEN + INFO = 3 + RETURN + END IF + END IF + KOUNT = KOUNT + 2 + END IF + IF ( TBYT ) THEN +C +C Solve the two-by-two Lyapunov equation (6.1) or (10.19), +C using the routine SB03OY. +C + B(1,1) = S(K,K) + B(2,1) = S(K+1,K) + B(1,2) = S(K,K+1) + B(2,2) = S(K+1,K+1) + U(1,1) = R(K,K) + U(1,2) = R(K,K+1) + U(2,2) = R(K+1,K+1) +C + CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, + $ SCALOC, INFO ) + IF ( INFO.GT.1 ) + $ RETURN + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 20 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 20 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + R(K,K) = U(1,1) + R(K,K+1) = U(1,2) + R(K+1,K+1) = U(2,2) +C +C If we are not at the end of S then set up and solve +C equation (6.2) or (10.20). +C +C Note that SB03OY returns ( u11*s11*inv( u11 ) ) in B +C and returns scaled alpha in A. ksize is the order of +C the remainder of S. k1, k2 and k3 point to the start +C of vectors in DWORK. +C + IF ( KOUNT.LE.N ) THEN + KSIZE = N - K - 1 + K1 = KSIZE + 1 + K2 = KSIZE + K1 + K3 = KSIZE + K2 +C +C Form the right-hand side of (6.2) or (10.20), the +C first column in DWORK( 1 ) ,..., DWORK( n - k - 1 ) +C the second in DWORK( n - k ) ,..., +C DWORK( 2*( n - k - 1 ) ). +C + CALL DCOPY( KSIZE, R(K,K+2), LDR, DWORK, 1 ) + CALL DCOPY( KSIZE, R(K+1,K+2), LDR, DWORK(K1), 1 ) + CALL DTRMM( 'Right', 'Upper', 'No transpose', + $ 'Non-unit', KSIZE, 2, -ONE, A, 2, DWORK, + $ KSIZE ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(K,K+2), LDS, DWORK, + $ 1 ) + CALL DAXPY( KSIZE, -R(K,K+1), S(K+1,K+2), LDS, + $ DWORK, 1) + CALL DAXPY( KSIZE, -R(K+1,K+1), S(K+1,K+2), LDS, + $ DWORK(K1), 1 ) + ELSE + CALL DAXPY( KSIZE, -R(K,K)*B(1,1), S(K,K+2), LDS, + $ DWORK, 1 ) + CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,1) + R(K+1,K+1) + $ *B(2,1) ), S(K+1,K+2), LDS, DWORK, 1 ) + CALL DAXPY( KSIZE, -R(K,K)*B(1,2), S(K,K+2), LDS, + $ DWORK(K1), 1 ) + CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,2) + R(K+1,K+1) + $ *B(2,2) ), S(K+1,K+2), LDS, DWORK(K1), + $ 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution +C is overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S(K+2,K+2), LDS, + $ B, 2, DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 30 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next 2*( n - k - 1 ) +C elements of DWORK. +C + CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) +C +C Now form the matrix Rhat of equation (6.4) or +C (10.22). Note that (10.22) is incorrect, so here we +C implement a corrected version of (10.22). +C + IF ( CONT ) THEN +C +C Swap the two rows of R with DWORK. +C + CALL DSWAP( KSIZE, DWORK, 1, R(K,K+2), LDR ) + CALL DSWAP( KSIZE, DWORK(K1), 1, R(K+1,K+2), LDR ) +C +C 1st column: +C + CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, + $ 1 ) + CALL DAXPY( KSIZE, -A(1,2), DWORK(K3), 1, DWORK, + $ 1 ) +C +C 2nd column: +C + CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, + $ DWORK(K1), 1 ) + ELSE +C +C Form v = S1'*u + s*u11', overwriting v on DWORK. +C +C Compute S1'*u, first multiplying by the +C triangular part of S1. +C + CALL DTRMM( 'Left', 'Upper', 'Transpose', + $ 'Non-unit', KSIZE, 2, ONE, S(K+2,K+2), + $ LDS, DWORK, KSIZE ) +C +C Then multiply by the subdiagonal of S1 and add in +C to the above result. +C + J1 = K1 + J2 = K + 2 +C + DO 40 J = 1, KSIZE-1 + IF ( S(J2+1,J2).NE.ZERO ) THEN + DWORK(J) = S(J2+1,J2)*DWORK(K2+J) + DWORK(J) + DWORK(J1) = S(J2+1,J2)*DWORK(K3+J) + + $ DWORK(J1) + END IF + J1 = J1 + 1 + J2 = J2 + 1 + 40 CONTINUE +C +C Add in s*u11'. +C + CALL DAXPY( KSIZE, R(K,K), S(K,K+2), LDS, DWORK, + $ 1 ) + CALL DAXPY( KSIZE, R(K,K+1), S(K+1,K+2), LDS, + $ DWORK, 1 ) + CALL DAXPY( KSIZE, R(K+1,K+1), S(K+1,K+2), LDS, + $ DWORK(K1), 1 ) +C +C Next recover r from R, swapping r with u. +C + CALL DSWAP( KSIZE, DWORK(K2), 1, R(K,K+2), LDR ) + CALL DSWAP( KSIZE, DWORK(K3), 1, R(K+1,K+2), LDR ) +C +C Now we perform the QR factorization. +C +C ( a ) = Q*( t ), +C ( b ) +C +C and form +C +C ( p' ) = Q'*( r' ). +C ( y' ) ( v' ) +C +C y is then the correct vector to use in (10.22). +C Note that a is upper triangular and that t and +C p are not required. +C + CALL DLARFG( 3, A(1,1), B(1,1), 1, TAU1 ) + V1 = B(1,1) + T1 = TAU1*V1 + V2 = B(2,1) + T2 = TAU1*V2 + SUM = A(1,2) + V1*B(1,2) + V2*B(2,2) + B(1,2) = B(1,2) - SUM*T1 + B(2,2) = B(2,2) - SUM*T2 + CALL DLARFG( 3, A(2,2), B(1,2), 1, TAU2 ) + V3 = B(1,2) + T3 = TAU2*V3 + V4 = B(2,2) + T4 = TAU2*V4 + J1 = K1 + J2 = K2 + J3 = K3 +C + DO 50 J = 1, KSIZE + SUM = DWORK(J2) + V1*DWORK(J) + V2*DWORK(J1) + D1 = DWORK(J) - SUM*T1 + D2 = DWORK(J1) - SUM*T2 + SUM = DWORK(J3) + V3*D1 + V4*D2 + DWORK(J) = D1 - SUM*T3 + DWORK(J1) = D2 - SUM*T4 + J1 = J1 + 1 + J2 = J2 + 1 + J3 = J3 + 1 + 50 CONTINUE +C + END IF +C +C Now update R1 to give Rhat. +C + CALL DCOPY( KSIZE, DWORK, 1, DWORK(K2), 1 ) + CALL DCOPY( KSIZE, DWORK(K1), 1, DWORK(K3), 1 ) + CALL DCOPY( KSIZE, DWORK(K3), 1, DWORK(2), 2 ) + CALL DCOPY( KSIZE, DWORK(K2), 1, DWORK(1), 2 ) + CALL MB04OD( 'Full', KSIZE, 0, 2, R(K+2,K+2), LDR, + $ DWORK, 2, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K3) ) + END IF + ELSE +C +C 1-by-1 block. +C +C Make sure S is stable or convergent and find u11 in +C equation (5.13) or (10.15). +C + IF ( DISCR ) THEN + ABSSKK = ABS( S(K,K) ) + IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) + ELSE + IF ( S(K,K).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ABS( TWO*S(K,K) ) ) + END IF +C + SCALOC = ONE + IF( TEMP.LT.SMIN ) THEN + TEMP = SMIN + INFOM = 1 + END IF + DR = ABS( R(K,K) ) + IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN + IF( DR.GT.BIGNUM*TEMP ) + $ SCALOC = ONE / DR + END IF + ALPHA = SIGN( TEMP, R(K,K) ) + R(K,K) = R(K,K)/ALPHA + IF( SCALOC.NE.ONE ) THEN +C + DO 60 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 60 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C If we are not at the end of S then set up and solve +C equation (5.14) or (10.16). ksize is the order of the +C remainder of S. k1 and k2 point to the start of vectors +C in DWORK. +C + IF ( KOUNT.LE.N ) THEN + KSIZE = N - K + K1 = KSIZE + 1 + K2 = KSIZE + K1 +C +C Form the right-hand side in DWORK( 1 ),..., +C DWORK( n - k ). +C + CALL DCOPY( KSIZE, R(K,K+1), LDR, DWORK, 1 ) + CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(K,K+1), LDS, DWORK, + $ 1 ) + ELSE + CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(K,K+1), LDS, + $ DWORK, 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution is +C overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S(K+1,K+1), LDS, + $ S(K,K), 1, DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 70 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next ( n - k ) elements +C of DWORK, copy the solution back into R and copy +C the row of R back into DWORK. +C + CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) + CALL DSWAP( KSIZE, DWORK, 1, R(K,K+1), LDR ) +C +C Now form the matrix Rhat of equation (5.15) or +C (10.17), first computing y in DWORK, and then +C updating R1. +C + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) + ELSE +C +C First form lambda( 1 )*r and then add in +C alpha*u11*s. +C + CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) + CALL DAXPY( KSIZE, ALPHA*R(K,K), S(K,K+1), LDS, + $ DWORK, 1 ) +C +C Now form alpha*S1'*u, first multiplying by the +C sub-diagonal of S1 and then the triangular part +C of S1, and add the result in DWORK. +C + J1 = K + 1 +C + DO 80 J = 1, KSIZE-1 + IF ( S(J1+1,J1).NE.ZERO ) DWORK(J) + $ = ALPHA*S(J1+1,J1)*DWORK(K1+J) + DWORK(J) + J1 = J1 + 1 + 80 CONTINUE +C + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', + $ KSIZE, S(K+1,K+1), LDS, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) + END IF + CALL MB04OD( 'Full', KSIZE, 0, 1, R(K+1,K+1), LDR, + $ DWORK, 1, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K1) ) + END IF + END IF + GO TO 10 + END IF +C END WHILE 10 +C + ELSE +C +C Case op(M) = M'. +C + KOUNT = N +C + 90 CONTINUE +C WHILE( KOUNT.GE.1 )LOOP + IF ( KOUNT.GE.1 ) THEN + K = KOUNT + IF ( KOUNT.EQ.1 ) THEN + TBYT = .FALSE. + KOUNT = KOUNT - 1 + ELSE IF ( S(K,K-1).EQ.ZERO ) THEN + TBYT = .FALSE. + KOUNT = KOUNT - 1 + ELSE + TBYT = .TRUE. + K = K - 1 + IF ( K.GT.1 ) THEN + IF ( S(K,K-1).NE.ZERO ) THEN + INFO = 3 + RETURN + END IF + END IF + KOUNT = KOUNT - 2 + END IF + IF ( TBYT ) THEN +C +C Solve the two-by-two Lyapunov equation corresponding to +C (6.1) or (10.19), using the routine SB03OY. +C + B(1,1) = S(K,K) + B(2,1) = S(K+1,K) + B(1,2) = S(K,K+1) + B(2,2) = S(K+1,K+1) + U(1,1) = R(K,K) + U(1,2) = R(K,K+1) + U(2,2) = R(K+1,K+1) +C + CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2, + $ SCALOC, INFO ) + IF ( INFO.GT.1 ) + $ RETURN + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 100 CONTINUE +C + SCALE = SCALE*SCALOC + END IF + R(K,K) = U(1,1) + R(K,K+1) = U(1,2) + R(K+1,K+1) = U(2,2) +C +C If we are not at the front of S then set up and solve +C equation corresponding to (6.2) or (10.20). +C +C Note that SB03OY returns ( inv( u11 )*s11*u11 ) in B +C and returns scaled alpha, alpha = inv( u11 )*r11, in A. +C ksize is the order of the remainder leading part of S. +C k1, k2 and k3 point to the start of vectors in DWORK. +C + IF ( KOUNT.GE.1 ) THEN + KSIZE = K - 1 + K1 = KSIZE + 1 + K2 = KSIZE + K1 + K3 = KSIZE + K2 +C +C Form the right-hand side of equations corresponding to +C (6.2) or (10.20), the first column in DWORK( 1 ) ,..., +C DWORK( k - 1 ) the second in DWORK( k ) ,..., +C DWORK( 2*( k - 1 ) ). +C + CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) + CALL DCOPY( KSIZE, R(1,K+1), 1, DWORK(K1), 1 ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit', + $ KSIZE, 2, -ONE, A, 2, DWORK, KSIZE ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, -R(K,K+1), S(1,K), 1, DWORK(K1), + $ 1 ) + CALL DAXPY( KSIZE, -R(K+1,K+1), S(1,K+1), 1, + $ DWORK(K1), 1 ) + ELSE + CALL DAXPY( KSIZE, -( R(K,K)*B(1,1) + R(K,K+1) + $ *B(1,2) ), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, -R(K+1,K+1)*B(1,2), S(1,K+1), 1, + $ DWORK, 1 ) + CALL DAXPY( KSIZE, -( R(K,K)*B(2,1) + R(K,K+1) + $ *B(2,2) ), S(1,K), 1, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, -R(K+1,K+1)*B(2,2), S(1,K+1), 1, + $ DWORK(K1), 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution +C is overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S, LDS, B, 2, + $ DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 110 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 110 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next 2*( k - 1 ) elements +C of DWORK. +C + CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 ) +C +C Now form the matrix Rhat of equation corresponding +C to (6.4) or (10.22) (corrected version). +C + IF ( CONT ) THEN +C +C Swap the two columns of R with DWORK. +C + CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) + CALL DSWAP( KSIZE, DWORK(K1), 1, R(1,K+1), 1 ) +C +C 1st column: +C + CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK, + $ 1 ) +C +C 2nd column: +C + CALL DAXPY( KSIZE, -A(1,2), DWORK(K2), 1, + $ DWORK(K1), 1 ) + CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1, + $ DWORK(K1), 1 ) + ELSE +C +C Form v = S1*u + s*u11, overwriting v on DWORK. +C +C Compute S1*u, first multiplying by the triangular +C part of S1. +C + CALL DTRMM( 'Left', 'Upper', 'No transpose', + $ 'Non-unit', KSIZE, 2, ONE, S, LDS, + $ DWORK, KSIZE ) +C +C Then multiply by the subdiagonal of S1 and add in +C to the above result. +C + J1 = K1 +C + DO 120 J = 2, KSIZE + J1 = J1 + 1 + IF ( S(J,J-1).NE.ZERO ) THEN + DWORK(J) = S(J,J-1)*DWORK(K2+J-2) + DWORK(J) + DWORK(J1) = S(J,J-1)*DWORK(K3+J-2) + + $ DWORK(J1) + END IF + 120 CONTINUE +C +C Add in s*u11. +C + CALL DAXPY( KSIZE, R(K,K), S(1,K), 1, DWORK, 1 ) + CALL DAXPY( KSIZE, R(K,K+1), S(1,K), 1, DWORK(K1), + $ 1 ) + CALL DAXPY( KSIZE, R(K+1,K+1), S(1,K+1), 1, + $ DWORK(K1), 1 ) +C +C Next recover r from R, swapping r with u. +C + CALL DSWAP( KSIZE, DWORK(K2), 1, R(1,K), 1 ) + CALL DSWAP( KSIZE, DWORK(K3), 1, R(1,K+1), 1 ) +C +C Now we perform the QL factorization. +C +C ( a' ) = Q*( t ), +C ( b' ) +C +C and form +C +C ( p' ) = Q'*( r' ). +C ( y' ) ( v' ) +C +C y is then the correct vector to use in the +C relation corresponding to (10.22). +C Note that a is upper triangular and that t and +C p are not required. +C + CALL DLARFG( 3, A(2,2), B(2,1), 2, TAU1 ) + V1 = B(2,1) + T1 = TAU1*V1 + V2 = B(2,2) + T2 = TAU1*V2 + SUM = A(1,2) + V1*B(1,1) + V2*B(1,2) + B(1,1) = B(1,1) - SUM*T1 + B(1,2) = B(1,2) - SUM*T2 + CALL DLARFG( 3, A(1,1), B(1,1), 2, TAU2 ) + V3 = B(1,1) + T3 = TAU2*V3 + V4 = B(1,2) + T4 = TAU2*V4 + J1 = K1 + J2 = K2 + J3 = K3 +C + DO 130 J = 1, KSIZE + SUM = DWORK(J3) + V1*DWORK(J) + V2*DWORK(J1) + D1 = DWORK(J) - SUM*T1 + D2 = DWORK(J1) - SUM*T2 + SUM = DWORK(J2) + V3*D1 + V4*D2 + DWORK(J) = D1 - SUM*T3 + DWORK(J1) = D2 - SUM*T4 + J1 = J1 + 1 + J2 = J2 + 1 + J3 = J3 + 1 + 130 CONTINUE +C + END IF +C +C Now update R1 to give Rhat. +C + CALL MB04ND( 'Full', KSIZE, 0, 2, R, LDR, DWORK, + $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K3) ) + END IF + ELSE +C +C 1-by-1 block. +C +C Make sure S is stable or convergent and find u11 in +C equation corresponding to (5.13) or (10.15). +C + IF ( DISCR ) THEN + ABSSKK = ABS( S(K,K) ) + IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) ) + ELSE + IF ( S(K,K).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + TEMP = SQRT( ABS( TWO*S(K,K) ) ) + END IF +C + SCALOC = ONE + IF( TEMP.LT.SMIN ) THEN + TEMP = SMIN + INFOM = 1 + END IF + DR = ABS( R(K,K) ) + IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN + IF( DR.GT.BIGNUM*TEMP ) + $ SCALOC = ONE / DR + END IF + ALPHA = SIGN( TEMP, R(K,K) ) + R(K,K) = R(K,K)/ALPHA + IF( SCALOC.NE.ONE ) THEN +C + DO 140 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 140 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C If we are not at the front of S then set up and solve +C equation corresponding to (5.14) or (10.16). ksize is +C the order of the remainder leading part of S. k1 and k2 +C point to the start of vectors in DWORK. +C + IF ( KOUNT.GE.1 ) THEN + KSIZE = K - 1 + K1 = KSIZE + 1 + K2 = KSIZE + K1 +C +C Form the right-hand side in DWORK( 1 ),..., +C DWORK( k - 1 ). +C + CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 ) + CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 ) + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 ) + ELSE + CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(1,K), 1, + $ DWORK, 1 ) + END IF +C +C SB03OR solves the Sylvester equations. The solution is +C overwritten on DWORK. +C + CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S, LDS, S(K,K), + $ 1, DWORK, KSIZE, SCALOC, INFO ) + INFOM = MAX( INFO, INFOM ) + IF( SCALOC.NE.ONE ) THEN +C + DO 150 J = 1, N + CALL DSCAL( J, SCALOC, R(1,J), 1 ) + 150 CONTINUE +C + SCALE = SCALE*SCALOC + END IF +C +C Copy the solution into the next ( k - 1 ) elements +C of DWORK, copy the solution back into R and copy +C the column of R back into DWORK. +C + CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 ) + CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 ) +C +C Now form the matrix Rhat of equation corresponding +C to (5.15) or (10.17), first computing y in DWORK, +C and then updating R1. +C + IF ( CONT ) THEN + CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 ) + ELSE +C +C First form lambda( 1 )*r and then add in +C alpha*u11*s. +C + CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 ) + CALL DAXPY( KSIZE, ALPHA*R(K,K), S(1,K), 1, DWORK, + $ 1 ) +C +C Now form alpha*S1*u, first multiplying by the +C sub-diagonal of S1 and then the triangular part +C of S1, and add the result in DWORK. +C + DO 160 J = 2, KSIZE + IF ( S(J,J-1).NE.ZERO ) DWORK(J) + $ = ALPHA*S(J,J-1)*DWORK(K1+J-2) + DWORK(J) + 160 CONTINUE +C + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', + $ KSIZE, S, LDS, DWORK(K1), 1 ) + CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 ) + END IF + CALL MB04ND( 'Full', KSIZE, 0, 1, R, LDR, DWORK, + $ KSIZE, DWORK, 1, DWORK, 1, DWORK(K2), + $ DWORK(K1) ) + END IF + END IF + GO TO 90 + END IF +C END WHILE 90 +C + END IF + INFO = INFOM + RETURN +C *** Last line of SB03OT *** + END diff --git a/mex/sources/libslicot/SB03OU.f b/mex/sources/libslicot/SB03OU.f new file mode 100644 index 000000000..d9ae8cb17 --- /dev/null +++ b/mex/sources/libslicot/SB03OU.f @@ -0,0 +1,410 @@ + SUBROUTINE SB03OU( DISCR, LTRANS, N, M, A, LDA, B, LDB, TAU, U, + $ LDU, SCALE, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X = op(U)'*op(U) either the stable non-negative +C definite continuous-time Lyapunov equation +C 2 +C op(A)'*X + X*op(A) = -scale *op(B)'*op(B) (1) +C +C or the convergent non-negative definite discrete-time Lyapunov +C equation +C 2 +C op(A)'*X*op(A) - X = -scale *op(B)'*op(B) (2) +C +C where op(K) = K or K' (i.e., the transpose of the matrix K), A is +C an N-by-N matrix in real Schur form, op(B) is an M-by-N matrix, +C U is an upper triangular matrix containing the Cholesky factor of +C the solution matrix X, X = op(U)'*op(U), and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C If matrix B has full rank then the solution matrix X will be +C positive-definite and hence the Cholesky factor U will be +C nonsingular, but if B is rank deficient then X may only be +C positive semi-definite and U will be singular. +C +C In the case of equation (1) the matrix A must be stable (that +C is, all the eigenvalues of A must have negative real parts), +C and for equation (2) the matrix A must be convergent (that is, +C all the eigenvalues of A must lie inside the unit circle). +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the type of Lyapunov equation to be solved as +C follows: +C = .TRUE. : Equation (2), discrete-time case; +C = .FALSE.: Equation (1), continuous-time case. +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A and the number of columns in +C matrix op(B). N >= 0. +C +C M (input) INTEGER +C The number of rows in matrix op(B). M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain a real Schur form matrix S. The elements +C below the upper Hessenberg part of the array A are not +C referenced. The 2-by-2 blocks must only correspond to +C complex conjugate pairs of eigenvalues (not to real +C eigenvalues). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C if LTRANS = .FALSE., and dimension (LDB,M), if +C LTRANS = .TRUE.. +C On entry, if LTRANS = .FALSE., the leading M-by-N part of +C this array must contain the coefficient matrix B of the +C equation. +C On entry, if LTRANS = .TRUE., the leading N-by-M part of +C this array must contain the coefficient matrix B of the +C equation. +C On exit, if LTRANS = .FALSE., the leading +C MIN(M,N)-by-MIN(M,N) upper triangular part of this array +C contains the upper triangular matrix R (as defined in +C METHOD), and the M-by-MIN(M,N) strictly lower triangular +C part together with the elements of the array TAU are +C overwritten by details of the matrix P (also defined in +C METHOD). When M < N, columns (M+1),...,N of the array B +C are overwritten by the matrix Z (see METHOD). +C On exit, if LTRANS = .TRUE., the leading +C MIN(M,N)-by-MIN(M,N) upper triangular part of +C B(1:N,M-N+1), if M >= N, or of B(N-M+1:N,1:M), if M < N, +C contains the upper triangular matrix R (as defined in +C METHOD), and the remaining elements (below the diagonal +C of R) together with the elements of the array TAU are +C overwritten by details of the matrix P (also defined in +C METHOD). When M < N, rows 1,...,(N-M) of the array B +C are overwritten by the matrix Z (see METHOD). +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,M), if LTRANS = .FALSE., +C LDB >= MAX(1,N), if LTRANS = .TRUE.. +C +C TAU (output) DOUBLE PRECISION array of dimension (MIN(N,M)) +C This array contains the scalar factors of the elementary +C reflectors defining the matrix P. +C +C U (output) DOUBLE PRECISION array of dimension (LDU,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor of the solution matrix X of +C the problem, X = op(U)'*op(U). +C The array U may be identified with B in the calling +C statement, if B is properly dimensioned, and the +C intermediate results returned in B are not needed. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, or INFO = 1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,4*N). +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DISCR = .FALSE., this means that while the matrix +C A has computed eigenvalues with negative real parts, +C it is only just stable in the sense that small +C perturbations in A can make one or more of the +C eigenvalues have a non-negative real part; +C if DISCR = .TRUE., this means that while the matrix +C A has computed eigenvalues inside the unit circle, +C it is nevertheless only just convergent, in the +C sense that small perturbations in A can make one or +C more of the eigenvalues lie outside the unit circle; +C perturbed values were used to solve the equation +C (but the matrix A is unchanged); +C = 2: if matrix A is not stable (that is, one or more of +C the eigenvalues of A has a non-negative real part), +C if DISCR = .FALSE., or not convergent (that is, one +C or more of the eigenvalues of A lies outside the +C unit circle), if DISCR = .TRUE.; +C = 3: if matrix A has two or more consecutive non-zero +C elements on the first sub-diagonal, so that there is +C a block larger than 2-by-2 on the diagonal; +C = 4: if matrix A has a 2-by-2 diagonal block with real +C eigenvalues instead of a complex conjugate pair. +C +C METHOD +C +C The method used by the routine is based on the Bartels and +C Stewart method [1], except that it finds the upper triangular +C matrix U directly without first finding X and without the need +C to form the normal matrix op(B)'*op(B) [2]. +C +C If LTRANS = .FALSE., the matrix B is factored as +C +C B = P ( R ), M >= N, B = P ( R Z ), M < N, +C ( 0 ) +C +C (QR factorization), where P is an M-by-M orthogonal matrix and +C R is a square upper triangular matrix. +C +C If LTRANS = .TRUE., the matrix B is factored as +C +C B = ( 0 R ) P, M >= N, B = ( Z ) P, M < N, +C ( R ) +C +C (RQ factorization), where P is an M-by-M orthogonal matrix and +C R is a square upper triangular matrix. +C +C These factorizations are used to solve the continuous-time +C Lyapunov equation in the canonical form +C 2 +C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), +C +C or the discrete-time Lyapunov equation in the canonical form +C 2 +C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F), +C +C where U and F are N-by-N upper triangular matrices, and +C +C F = R, if M >= N, or +C +C F = ( R ), if LTRANS = .FALSE., or +C ( 0 ) +C +C F = ( 0 Z ), if LTRANS = .TRUE., if M < N. +C ( 0 R ) +C +C The canonical equation is solved for U. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. +C Solution of the matrix equation A'X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if A is only just stable (or convergent) then the Lyapunov +C equation will be ill-conditioned. "Large" elements in U relative +C to those of A and B, or a "small" value for scale, are symptoms +C of ill-conditioning. A condition estimate can be computed using +C SLICOT Library routine SB03MD. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine SB03CZ by Sven Hammarling, +C NAG Ltd, United Kingdom. +C Partly based on routine PLYAPS by A. Varga, University of Bochum, +C May 1992. +C +C REVISIONS +C +C Dec. 1997, April 1998, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, LDA, LDB, LDU, LDWORK, M, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), TAU(*), U(LDU,*) +C .. Local Scalars .. + INTEGER I, J, K, L, MN, WRKOPT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEQRF, DGERQF, DLACPY, DLASET, SB03OT, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( ( LDB.LT.MAX( 1, M ) .AND. .NOT.LTRANS ) .OR. + $ ( LDB.LT.MAX( 1, N ) .AND. LTRANS ) ) THEN + INFO = -8 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MAX( 1, 4*N ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB03OU', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + MN = MIN( N, M ) + IF ( MN.EQ.0 ) THEN + SCALE = ONE + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( LTRANS ) THEN +C +C Case op(K) = K'. +C +C Perform the RQ factorization of B. +C Workspace: need N; +C prefer N*NB. +C + CALL DGERQF( N, M, B, LDB, TAU, DWORK, LDWORK, INFO ) +C +C The triangular matrix F is constructed in the array U so that +C U can share the same memory as B. +C + IF ( M.GE.N ) THEN + CALL DLACPY( 'Upper', MN, N, B(1,M-N+1), LDB, U, LDU ) + ELSE +C + DO 10 I = M, 1, -1 + CALL DCOPY( N-M+I, B(1,I), 1, U(1,N-M+I), 1 ) + 10 CONTINUE +C + CALL DLASET( 'Full', N, N-M, ZERO, ZERO, U, LDU ) + END IF + ELSE +C +C Case op(K) = K. +C +C Perform the QR factorization of B. +C Workspace: need N; +C prefer N*NB. +C + CALL DGEQRF( M, N, B, LDB, TAU, DWORK, LDWORK, INFO ) + CALL DLACPY( 'Upper', MN, N, B, LDB, U, LDU ) + IF ( M.LT.N ) + $ CALL DLASET( 'Upper', N-M, N-M, ZERO, ZERO, U(M+1,M+1), + $ LDU ) + END IF + WRKOPT = DWORK(1) +C +C Solve the canonical Lyapunov equation +C 2 +C op(A)'*op(U)'*op(U) + op(U)'*op(U)*op(A) = -scale *op(F)'*op(F), +C +C or +C 2 +C op(A)'*op(U)'*op(U)*op(A) - op(U)'*op(U) = -scale *op(F)'*op(F) +C +C for U. +C + CALL SB03OT( DISCR, LTRANS, N, A, LDA, U, LDU, SCALE, DWORK, + $ INFO ) + IF ( INFO.NE.0 .AND. INFO.NE.1 ) + $ RETURN +C +C Make the diagonal elements of U non-negative. +C + IF ( LTRANS ) THEN +C + DO 30 J = 1, N + IF ( U(J,J).LT.ZERO ) THEN +C + DO 20 I = 1, J + U(I,J) = -U(I,J) + 20 CONTINUE +C + END IF + 30 CONTINUE +C + ELSE + K = 1 +C + DO 50 J = 1, N + DWORK(K) = U(J,J) + L = 1 +C + DO 40 I = 1, J + IF ( DWORK(L).LT.ZERO ) U(I,J) = -U(I,J) + L = L + 1 + 40 CONTINUE +C + K = K + 1 + 50 CONTINUE +C + END IF +C + DWORK(1) = MAX( WRKOPT, 4*N ) + RETURN +C *** Last line of SB03OU *** + END diff --git a/mex/sources/libslicot/SB03OV.f b/mex/sources/libslicot/SB03OV.f new file mode 100644 index 000000000..bd92699b8 --- /dev/null +++ b/mex/sources/libslicot/SB03OV.f @@ -0,0 +1,105 @@ + SUBROUTINE SB03OV( A, B, C, S ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct a complex plane rotation such that, for a complex +C number a and a real number b, +C +C ( conjg( c ) s )*( a ) = ( d ), +C ( -s c ) ( b ) ( 0 ) +C +C where d is always real and is overwritten on a, so that on +C return the imaginary part of a is zero. b is unaltered. +C +C This routine has A and C declared as REAL, because it is intended +C for use within a real Lyapunov solver and the REAL declarations +C mean that a standard Fortran DOUBLE PRECISION version may be +C readily constructed. However A and C could safely be declared +C COMPLEX in the calling program, although some systems may give a +C type mismatch warning. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C A (input/output) DOUBLE PRECISION array, dimension (2) +C On entry, A(1) and A(2) must contain the real and +C imaginary part, respectively, of the complex number a. +C On exit, A(1) contains the real part of d, and A(2) is +C set to zero. +C +C B (input) DOUBLE PRECISION +C The real number b. +C +C C (output) DOUBLE PRECISION array, dimension (2) +C C(1) and C(2) contain the real and imaginary part, +C respectively, of the complex number c, the cosines of +C the plane rotation. +C +C S (output) DOUBLE PRECISION +C The real number s, the sines of the plane rotation. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB03CV by Sven Hammarling, +C NAG Ltd., United Kingdom, May 1985. +C +C REVISIONS +C +C Dec. 1997. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION B, S +C .. Array Arguments .. + DOUBLE PRECISION A(2), C(2) +C .. Local Scalars .. + DOUBLE PRECISION D +C .. External Functions .. + DOUBLE PRECISION DLAPY3 + EXTERNAL DLAPY3 +C .. Executable Statements .. +C + D = DLAPY3( A(1), A(2), B ) + IF ( D.EQ.ZERO ) THEN + C(1) = ONE + C(2) = ZERO + S = ZERO + ELSE + C(1) = A(1)/D + C(2) = A(2)/D + S = B/D + A(1) = D + A(2) = ZERO + END IF +C + RETURN +C *** Last line of SB03OV *** + END diff --git a/mex/sources/libslicot/SB03OY.f b/mex/sources/libslicot/SB03OY.f new file mode 100644 index 000000000..44a94b979 --- /dev/null +++ b/mex/sources/libslicot/SB03OY.f @@ -0,0 +1,693 @@ + SUBROUTINE SB03OY( DISCR, LTRANS, ISGN, S, LDS, R, LDR, A, LDA, + $ SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for the Cholesky factor U of X, +C +C op(U)'*op(U) = X, +C +C where U is a two-by-two upper triangular matrix, either the +C continuous-time two-by-two Lyapunov equation +C 2 +C op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R), +C +C when DISCR = .FALSE., or the discrete-time two-by-two Lyapunov +C equation +C 2 +C op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R), +C +C when DISCR = .TRUE., where op(K) = K or K' (i.e., the transpose of +C the matrix K), S is a two-by-two matrix with complex conjugate +C eigenvalues, R is a two-by-two upper triangular matrix, +C ISGN = -1 or 1, and scale is an output scale factor, set less +C than or equal to 1 to avoid overflow in X. The routine also +C computes two matrices, B and A, so that +C 2 +C B*U = U*S and A*U = scale *R, if LTRANS = .FALSE., or +C 2 +C U*B = S*U and U*A = scale *R, if LTRANS = .TRUE., +C which are used by the general Lyapunov solver. +C In the continuous-time case ISGN*S must be stable, so that its +C eigenvalues must have strictly negative real parts. +C In the discrete-time case S must be convergent if ISGN = 1, that +C is, its eigenvalues must have moduli less than unity, or S must +C be completely divergent if ISGN = -1, that is, its eigenvalues +C must have moduli greater than unity. +C +C ARGUMENTS +C +C Mode Parameters +C +C DISCR LOGICAL +C Specifies the equation to be solved: 2 +C = .FALSE.: op(S)'*X + X*op(S) = -ISGN*scale *op(R)'*op(R); +C 2 +C = .TRUE. : op(S)'*X*op(S) - X = -ISGN*scale *op(R)'*op(R). +C +C LTRANS LOGICAL +C Specifies the form of op(K) to be used, as follows: +C = .FALSE.: op(K) = K (No transpose); +C = .TRUE. : op(K) = K**T (Transpose). +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C S (input/output) DOUBLE PRECISION array, dimension (LDS,2) +C On entry, S must contain a 2-by-2 matrix. +C On exit, S contains a 2-by-2 matrix B such that B*U = U*S, +C if LTRANS = .FALSE., or U*B = S*U, if LTRANS = .TRUE.. +C Notice that if U is nonsingular then +C B = U*S*inv( U ), if LTRANS = .FALSE. +C B = inv( U )*S*U, if LTRANS = .TRUE.. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= 2. +C +C R (input/output) DOUBLE PRECISION array, dimension (LDR,2) +C On entry, R must contain a 2-by-2 upper triangular matrix. +C The element R( 2, 1 ) is not referenced. +C On exit, R contains U, the 2-by-2 upper triangular +C Cholesky factor of the solution X, X = op(U)'*op(U). +C +C LDR INTEGER +C The leading dimension of array R. LDR >= 2. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,2) +C A contains a 2-by-2 upper triangular matrix A satisfying +C A*U/scale = scale*R, if LTRANS = .FALSE., or +C U*A/scale = scale*R, if LTRANS = .TRUE.. +C Notice that if U is nonsingular then +C A = scale*scale*R*inv( U ), if LTRANS = .FALSE. +C A = scale*scale*inv( U )*R, if LTRANS = .TRUE.. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Lyapunov equation is (nearly) singular +C (warning indicator); +C if DISCR = .FALSE., this means that while the +C matrix S has computed eigenvalues with negative real +C parts, it is only just stable in the sense that +C small perturbations in S can make one or more of the +C eigenvalues have a non-negative real part; +C if DISCR = .TRUE., this means that while the +C matrix S has computed eigenvalues inside the unit +C circle, it is nevertheless only just convergent, in +C the sense that small perturbations in S can make one +C or more of the eigenvalues lie outside the unit +C circle; +C perturbed values were used to solve the equation +C (but the matrix S is unchanged); +C = 2: if DISCR = .FALSE., and ISGN*S is not stable or +C if DISCR = .TRUE., ISGN = 1 and S is not convergent +C or if DISCR = .TRUE., ISGN = -1 and S is not +C completely divergent; +C = 4: if S has real eigenvalues. +C +C NOTE: In the interests of speed, this routine does not check all +C inputs for errors. +C +C METHOD +C +C The LAPACK scheme for solving 2-by-2 Sylvester equations is +C adapted for 2-by-2 Lyapunov equations, but directly computing the +C Cholesky factor of the solution. +C +C REFERENCES +C +C [1] Hammarling S. J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-325, 1982. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB03CY by Sven Hammarling, +C NAG Ltd., United Kingdom, November 1986. +C Partly based on SB03CY and PLYAP2 by A. Varga, University of +C Bochum, May 1992. +C +C REVISIONS +C +C Dec. 1997, April 1998. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ***************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, FOUR + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ FOUR = 4.0D0 ) +C .. Scalar Arguments .. + LOGICAL DISCR, LTRANS + INTEGER INFO, ISGN, LDA, LDR, LDS + DOUBLE PRECISION SCALE +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + DOUBLE PRECISION ABSB, ABSG, ABST, ALPHA, BIGNUM, E1, E2, EPS, + $ ETA, P1, P3, P3I, P3R, S11, S12, S21, S22, + $ SCALOC, SGN, SMIN, SMLNUM, SNP, SNQ, SNT, TEMPI, + $ TEMPR, V1, V3 +C .. Local Arrays .. + DOUBLE PRECISION CSP(2), CSQ(2), CST(2), DELTA(2), DP(2), DT(2), + $ G(2), GAMMA(2), P2(2), T(2), TEMP(2), V2(2), + $ X11(2), X12(2), X21(2), X22(2), Y(2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DLAPY3 + EXTERNAL DLAMCH, DLAPY2, DLAPY3 +C .. External Subroutines .. + EXTERNAL DLABAD, DLANV2, SB03OV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Executable Statements .. +C +C The comments in this routine refer to notation and equation +C numbers in sections 6 and 10 of [1]. +C +C Find the eigenvalue lambda = E1 - i*E2 of s11. +C + INFO = 0 + SGN = ISGN + S11 = S(1,1) + S12 = S(1,2) + S21 = S(2,1) + S22 = S(2,2) +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*FOUR / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*MAX( ABS( S11 ), ABS( S12 ), + $ ABS( S21 ), ABS( S22 ) ) ) + SCALE = ONE +C + CALL DLANV2( S11, S12, S21, S22, TEMPR, TEMPI, E1, E2, CSP, CSQ ) + IF ( TEMPI.EQ.ZERO ) THEN + INFO = 4 + RETURN + END IF + ABSB = DLAPY2( E1, E2 ) + IF ( DISCR ) THEN + IF ( SGN*( ABSB - ONE ).GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + ELSE + IF ( SGN*E1.GE.ZERO ) THEN + INFO = 2 + RETURN + END IF + END IF +C +C Compute the cos and sine that define Qhat. The sine is real. +C + TEMP(1) = S(1,1) - E1 + TEMP(2) = E2 + IF ( LTRANS ) TEMP(2) = -E2 + CALL SB03OV( TEMP, S(2,1), CSQ, SNQ ) +C +C beta in (6.9) is given by beta = E1 + i*E2, compute t. +C + TEMP(1) = CSQ(1)*S(1,2) - SNQ*S(1,1) + TEMP(2) = CSQ(2)*S(1,2) + TEMPR = CSQ(1)*S(2,2) - SNQ*S(2,1) + TEMPI = CSQ(2)*S(2,2) + T(1) = CSQ(1)*TEMP(1) - CSQ(2)*TEMP(2) + SNQ*TEMPR + T(2) = CSQ(1)*TEMP(2) + CSQ(2)*TEMP(1) + SNQ*TEMPI +C + IF ( LTRANS ) THEN +C ( -- ) +C Case op(M) = M'. Note that the modified R is ( p3 p2 ). +C ( 0 p1 ) +C +C Compute the cos and sine that define Phat. +C + TEMP(1) = CSQ(1)*R(2,2) - SNQ*R(1,2) + TEMP(2) = -CSQ(2)*R(2,2) + CALL SB03OV( TEMP, -SNQ*R(1,1), CSP, SNP ) +C +C Compute p1, p2 and p3 of the relation corresponding to (6.11). +C + P1 = TEMP(1) + TEMP(1) = CSQ(1)*R(1,2) + SNQ*R(2,2) + TEMP(2) = -CSQ(2)*R(1,2) + TEMPR = CSQ(1)*R(1,1) + TEMPI = -CSQ(2)*R(1,1) + P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR + P2(2) = -CSP(1)*TEMP(2) - CSP(2)*TEMP(1) - SNP*TEMPI + P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) + P3I = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*TEMP(2) + ELSE +C +C Case op(M) = M. +C +C Compute the cos and sine that define Phat. +C + TEMP(1) = CSQ(1)*R(1,1) + SNQ*R(1,2) + TEMP(2) = CSQ(2)*R(1,1) + CALL SB03OV( TEMP, SNQ*R(2,2), CSP, SNP ) +C +C Compute p1, p2 and p3 of (6.11). +C + P1 = TEMP(1) + TEMP(1) = CSQ(1)*R(1,2) - SNQ*R(1,1) + TEMP(2) = CSQ(2)*R(1,2) + TEMPR = CSQ(1)*R(2,2) + TEMPI = CSQ(2)*R(2,2) + P2(1) = CSP(1)*TEMP(1) - CSP(2)*TEMP(2) + SNP*TEMPR + P2(2) = CSP(1)*TEMP(2) + CSP(2)*TEMP(1) + SNP*TEMPI + P3R = CSP(1)*TEMPR + CSP(2)*TEMPI - SNP*TEMP(1) + P3I = CSP(2)*TEMPR - CSP(1)*TEMPI + SNP*TEMP(2) + END IF +C +C Make p3 real by multiplying by conjg ( p3 )/abs( p3 ) to give +C +C p3 := abs( p3 ). +C + IF ( P3I.EQ.ZERO ) THEN + P3 = ABS( P3R ) + DP(1) = SIGN( ONE, P3R ) + DP(2) = ZERO + ELSE + P3 = DLAPY2( P3R, P3I ) + DP(1) = P3R/P3 + DP(2) = -P3I/P3 + END IF +C +C Now compute the quantities v1, v2, v3 and y in (6.13) - (6.15), +C or (10.23) - (10.25). Care is taken to avoid overflows. +C + IF ( DISCR ) THEN + ALPHA = SQRT( ABS( ONE - ABSB )*( ONE + ABSB ) ) + ELSE + ALPHA = SQRT( ABS( TWO*E1 ) ) + END IF +C + SCALOC = ONE + IF( ALPHA.LT.SMIN ) THEN + ALPHA = SMIN + INFO = 1 + END IF + ABST = ABS( P1 ) + IF( ALPHA.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ALPHA ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V1 = P1/ALPHA +C + IF ( DISCR ) THEN + G(1) = ( ONE - E1 )*( ONE + E1 ) + E2**2 + G(2) = -TWO*E1*E2 + ABSG = DLAPY2( G(1), G(2) ) + SCALOC = ONE + IF( ABSG.LT.SMIN ) THEN + ABSG = SMIN + INFO = 1 + END IF + TEMP(1) = SGN*ALPHA*P2(1) + V1*( E1*T(1) - E2*T(2) ) + TEMP(2) = SGN*ALPHA*P2(2) + V1*( E1*T(2) + E2*T(1) ) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/ABSG + TEMP(2) = TEMP(2)/ABSG +C + SCALOC = ONE + V2(1) = G(1)*TEMP(1) + G(2)*TEMP(2) + V2(2) = G(1)*TEMP(2) - G(2)*TEMP(1) + ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P1 = SCALOC*P1 + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V2(1) = V2(1)/ABSG + V2(2) = V2(2)/ABSG +C + SCALOC = ONE + TEMP(1) = P1*T(1) - TWO*E2*P2(2) + TEMP(2) = P1*T(2) + TWO*E2*P2(1) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/ABSG + TEMP(2) = TEMP(2)/ABSG +C + SCALOC = ONE + Y(1) = -( G(1)*TEMP(1) + G(2)*TEMP(2) ) + Y(2) = -( G(1)*TEMP(2) - G(2)*TEMP(1) ) + ABST = MAX( ABS( Y(1) ), ABS( Y(2) ) ) + IF( ABSG.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSG ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + Y(1) = SCALOC*Y(1) + Y(2) = SCALOC*Y(2) + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + Y(1) = Y(1)/ABSG + Y(2) = Y(2)/ABSG + ELSE +C + SCALOC = ONE + IF( ABSB.LT.SMIN ) THEN + ABSB = SMIN + INFO = 1 + END IF + TEMP(1) = SGN*ALPHA*P2(1) + V1*T(1) + TEMP(2) = SGN*ALPHA*P2(2) + V1*T(2) + ABST = MAX( ABS( TEMP(1) ), ABS( TEMP(2) ) ) + IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSB ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + TEMP(1) = SCALOC*TEMP(1) + TEMP(2) = SCALOC*TEMP(2) + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + TEMP(1) = TEMP(1)/( TWO*ABSB ) + TEMP(2) = TEMP(2)/( TWO*ABSB ) + SCALOC = ONE + V2(1) = -( E1*TEMP(1) + E2*TEMP(2) ) + V2(2) = -( E1*TEMP(2) - E2*TEMP(1) ) + ABST = MAX( ABS( V2(1) ), ABS( V2(2) ) ) + IF( ABSB.LT.ONE .AND. ABST.GT.ONE ) THEN + IF( ABST.GT.BIGNUM*ABSB ) + $ SCALOC = ONE / ABST + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + P2(1) = SCALOC*P2(1) + P2(2) = SCALOC*P2(2) + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V2(1) = V2(1)/ABSB + V2(2) = V2(2)/ABSB + Y(1) = P2(1) - ALPHA*V2(1) + Y(2) = P2(2) - ALPHA*V2(2) + END IF +C + SCALOC = ONE + V3 = DLAPY3( P3, Y(1), Y(2) ) + IF( ALPHA.LT.ONE .AND. V3.GT.ONE ) THEN + IF( V3.GT.BIGNUM*ALPHA ) + $ SCALOC = ONE / V3 + END IF + IF( SCALOC.NE.ONE ) THEN + V1 = SCALOC*V1 + V2(1) = SCALOC*V2(1) + V2(2) = SCALOC*V2(2) + V3 = SCALOC*V3 + P3 = SCALOC*P3 + SCALE = SCALOC*SCALE + END IF + V3 = V3/ALPHA +C + IF ( LTRANS ) THEN +C +C Case op(M) = M'. +C +C Form X = conjg( Qhat' )*v11. +C + X11(1) = CSQ(1)*V3 + X11(2) = CSQ(2)*V3 + X21(1) = SNQ*V3 + X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) - SNQ*V1 + X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) + X22(1) = CSQ(1)*V1 + SNQ*V2(1) + X22(2) = -CSQ(2)*V1 - SNQ*V2(2) +C +C Obtain u11 from the RQ-factorization of X. The conjugate of +C X22 should be taken. +C + X22(2) = -X22(2) + CALL SB03OV( X22, X21(1), CST, SNT ) + R(2,2) = X22(1) + R(1,2) = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) + TEMPR = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) + TEMPI = CST(1)*X11(2) - CST(2)*X11(1) - SNT*X12(2) + IF ( TEMPI.EQ.ZERO ) THEN + R(1,1) = ABS( TEMPR ) + DT(1) = SIGN( ONE, TEMPR ) + DT(2) = ZERO + ELSE + R(1,1) = DLAPY2( TEMPR, TEMPI ) + DT(1) = TEMPR/R(1,1) + DT(2) = -TEMPI/R(1,1) + END IF + ELSE +C +C Case op(M) = M. +C +C Now form X = v11*conjg( Qhat' ). +C + X11(1) = CSQ(1)*V1 - SNQ*V2(1) + X11(2) = -CSQ(2)*V1 + SNQ*V2(2) + X21(1) = -SNQ*V3 + X12(1) = CSQ(1)*V2(1) + CSQ(2)*V2(2) + SNQ*V1 + X12(2) = -CSQ(1)*V2(2) + CSQ(2)*V2(1) + X22(1) = CSQ(1)*V3 + X22(2) = CSQ(2)*V3 +C +C Obtain u11 from the QR-factorization of X. +C + CALL SB03OV( X11, X21(1), CST, SNT ) + R(1,1) = X11(1) + R(1,2) = CST(1)*X12(1) + CST(2)*X12(2) + SNT*X22(1) + TEMPR = CST(1)*X22(1) - CST(2)*X22(2) - SNT*X12(1) + TEMPI = CST(1)*X22(2) + CST(2)*X22(1) - SNT*X12(2) + IF ( TEMPI.EQ.ZERO ) THEN + R(2,2) = ABS( TEMPR ) + DT(1) = SIGN( ONE, TEMPR ) + DT(2) = ZERO + ELSE + R(2,2) = DLAPY2( TEMPR, TEMPI ) + DT(1) = TEMPR/R(2,2) + DT(2) = -TEMPI/R(2,2) + END IF + END IF +C +C The computations below are not needed when B and A are not +C useful. Compute delta, eta and gamma as in (6.21) or (10.26). +C + IF ( ( Y(1).EQ.ZERO ).AND.( Y(2).EQ.ZERO ) ) THEN + DELTA(1) = ZERO + DELTA(2) = ZERO + GAMMA(1) = ZERO + GAMMA(2) = ZERO + ETA = ALPHA + ELSE + DELTA(1) = Y(1)/V3 + DELTA(2) = Y(2)/V3 + GAMMA(1) = -ALPHA*DELTA(1) + GAMMA(2) = -ALPHA*DELTA(2) + ETA = P3/V3 + IF ( DISCR ) THEN + TEMPR = E1*DELTA(1) - E2*DELTA(2) + DELTA(2) = E1*DELTA(2) + E2*DELTA(1) + DELTA(1) = TEMPR + END IF + END IF +C + IF ( LTRANS ) THEN +C +C Case op(M) = M'. +C +C Find X = conjg( That' )*( inv( v11 )*s11hat*v11 ). +C ( Defer the scaling.) +C + X11(1) = CST(1)*E1 + CST(2)*E2 + X11(2) = -CST(1)*E2 + CST(2)*E1 + X21(1) = SNT*E1 + X21(2) = -SNT*E2 + X12(1) = SGN*( CST(1)*GAMMA(1) + CST(2)*GAMMA(2) ) - SNT*E1 + X12(2) = SGN*( -CST(1)*GAMMA(2) + CST(2)*GAMMA(1) ) - SNT*E2 + X22(1) = CST(1)*E1 + CST(2)*E2 + SGN*SNT*GAMMA(1) + X22(2) = CST(1)*E2 - CST(2)*E1 - SGN*SNT*GAMMA(2) +C +C Now find B = X*That. ( Include the scaling here.) +C + S(1,1) = CST(1)*X11(1) + CST(2)*X11(2) - SNT*X12(1) + TEMPR = CST(1)*X21(1) + CST(2)*X21(2) - SNT*X22(1) + TEMPI = CST(1)*X21(2) - CST(2)*X21(1) - SNT*X22(2) + S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI + TEMPR = CST(1)*X12(1) - CST(2)*X12(2) + SNT*X11(1) + TEMPI = CST(1)*X12(2) + CST(2)*X12(1) + SNT*X11(2) + S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + S(2,2) = CST(1)*X22(1) - CST(2)*X22(2) + SNT*X21(1) +C +C Form X = ( inv( v11 )*p11 )*conjg( Phat' ). +C + TEMPR = DP(1)*ETA + TEMPI = -DP(2)*ETA + X11(1) = CSP(1)*TEMPR - CSP(2)*TEMPI + SNP*DELTA(1) + X11(2) = CSP(1)*TEMPI + CSP(2)*TEMPR - SNP*DELTA(2) + X21(1) = SNP*ALPHA + X12(1) = -SNP*TEMPR + CSP(1)*DELTA(1) - CSP(2)*DELTA(2) + X12(2) = -SNP*TEMPI - CSP(1)*DELTA(2) - CSP(2)*DELTA(1) + X22(1) = CSP(1)*ALPHA + X22(2) = -CSP(2)*ALPHA +C +C Finally form A = conjg( That' )*X. +C + TEMPR = CST(1)*X11(1) - CST(2)*X11(2) - SNT*X21(1) + TEMPI = CST(1)*X22(2) + CST(2)*X22(1) + A(1,1) = DT(1)*TEMPR + DT(2)*TEMPI + TEMPR = CST(1)*X12(1) - CST(2)*X12(2) - SNT*X22(1) + TEMPI = CST(1)*X12(2) + CST(2)*X12(1) - SNT*X22(1) + A(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + A(2,1) = ZERO + A(2,2) = CST(1)*X22(1) + CST(2)*X22(2) + SNT*X12(1) + ELSE +C +C Case op(M) = M. +C +C Find X = That*( v11*s11hat*inv( v11 ) ). ( Defer the scaling.) +C + X11(1) = CST(1)*E1 + CST(2)*E2 + X11(2) = CST(1)*E2 - CST(2)*E1 + X21(1) = -SNT*E1 + X21(2) = -SNT*E2 + X12(1) = SGN*( CST(1)*GAMMA(1) - CST(2)*GAMMA(2) ) + SNT*E1 + X12(2) = SGN*( -CST(1)*GAMMA(2) - CST(2)*GAMMA(1) ) - SNT*E2 + X22(1) = CST(1)*E1 + CST(2)*E2 - SGN*SNT*GAMMA(1) + X22(2) = -CST(1)*E2 + CST(2)*E1 + SGN*SNT*GAMMA(2) +C +C Now find B = X*conjg( That' ). ( Include the scaling here.) +C + S(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) + TEMPR = CST(1)*X21(1) - CST(2)*X21(2) + SNT*X22(1) + TEMPI = CST(1)*X21(2) + CST(2)*X21(1) + SNT*X22(2) + S(2,1) = DT(1)*TEMPR - DT(2)*TEMPI + TEMPR = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) + TEMPI = CST(1)*X12(2) - CST(2)*X12(1) - SNT*X11(2) + S(1,2) = DT(1)*TEMPR + DT(2)*TEMPI + S(2,2) = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) +C +C Form X = Phat*( p11*inv( v11 ) ). +C + TEMPR = DP(1)*ETA + TEMPI = -DP(2)*ETA + X11(1) = CSP(1)*ALPHA + X11(2) = CSP(2)*ALPHA + X21(1) = SNP*ALPHA + X12(1) = CSP(1)*DELTA(1) + CSP(2)*DELTA(2) - SNP*TEMPR + X12(2) = -CSP(1)*DELTA(2) + CSP(2)*DELTA(1) - SNP*TEMPI + X22(1) = CSP(1)*TEMPR + CSP(2)*TEMPI + SNP*DELTA(1) + X22(2) = CSP(1)*TEMPI - CSP(2)*TEMPR - SNP*DELTA(2) +C +C Finally form A = X*conjg( That' ). +C + A(1,1) = CST(1)*X11(1) - CST(2)*X11(2) + SNT*X12(1) + A(2,1) = ZERO + A(1,2) = CST(1)*X12(1) + CST(2)*X12(2) - SNT*X11(1) + TEMPR = CST(1)*X22(1) + CST(2)*X22(2) - SNT*X21(1) + TEMPI = CST(1)*X22(2) - CST(2)*X22(1) + A(2,2) = DT(1)*TEMPR + DT(2)*TEMPI + END IF +C + IF( SCALE.NE.ONE ) THEN + A(1,1) = SCALE*A(1,1) + A(1,2) = SCALE*A(1,2) + A(2,2) = SCALE*A(2,2) + END IF +C + RETURN +C *** Last line of SB03OY *** + END diff --git a/mex/sources/libslicot/SB03PD.f b/mex/sources/libslicot/SB03PD.f new file mode 100644 index 000000000..8cef1572f --- /dev/null +++ b/mex/sources/libslicot/SB03PD.f @@ -0,0 +1,410 @@ + SUBROUTINE SB03PD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, + $ SCALE, SEPD, FERR, WR, WI, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real discrete Lyapunov matrix equation +C +C op(A)'*X*op(A) - X = scale*C +C +C and/or estimate the quantity, called separation, +C +C sepd(op(A),op(A)') = min norm(op(A)'*X*op(A) - X)/norm(X) +C +C where op(A) = A or A' (A**T) and C is symmetric (C = C'). +C (A' denotes the transpose of the matrix A.) A is N-by-N, the right +C hand side C and the solution X are N-by-N, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'B': Compute both the solution and the separation. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix in Schur canonical form. +C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N +C part of this array contains the upper quasi-triangular +C matrix in Schur canonical form from the Shur factorization +C of A. The contents of array A is not modified if +C FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If FACT = 'F', then U is an input argument and on entry +C it must contain the orthogonal matrix U from the real +C Schur factorization of A. +C If FACT = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO = N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with JOB = 'X' or 'B', the leading N-by-N part of +C this array must contain the symmetric matrix C. +C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, +C the leading N-by-N part of C has been overwritten by the +C symmetric solution matrix X. +C If JOB = 'S', C is not referenced. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C SEPD (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, +C SEPD contains the estimate in the 1-norm of +C sepd(op(A),op(A)'). +C If JOB = 'X' or N = 0, SEPD is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains +C an estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the relative +C error in the computed solution, measured in the Frobenius +C norm: norm(X - XTRUE)/norm(XTRUE). +C If JOB = 'X' or JOB = 'S', FERR is not referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of the +C eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1 and +C If JOB = 'X' then +C If FACT = 'F', LDWORK >= MAX(N*N,2*N); +C If FACT = 'N', LDWORK >= MAX(N*N,3*N). +C If JOB = 'S' or JOB = 'B' then +C LDWORK >= 2*N*N + 2*N. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues (see LAPACK Library routine DGEES); +C elements i+1:n of WR and WI contain eigenvalues +C which have converged, and A contains the partially +C converged Schur form; +C = N+1: if matrix A has almost reciprocal eigenvalues; +C perturbed values were used to solve the equation +C (but the matrix A is unchanged). +C +C METHOD +C +C After reducing matrix A to real Schur canonical form (if needed), +C a discrete-time version of the Bartels-Stewart algorithm is used. +C A set of equivalent linear algebraic systems of equations of order +C at most four are formed and solved using Gaussian elimination with +C complete pivoting. +C +C REFERENCES +C +C [1] Barraud, A.Y. T +C A numerical algorithm to solve A XA - X = Q. +C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. +C +C [2] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C SEPD is defined as +C +C sepd( op(A), op(A)' ) = sigma_min( T ) +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( op(A)', op(A)' ) - I(N**2). +C +C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the +C Kronecker product. The program estimates sigma_min(T) by the +C reciprocal of an estimate of the 1-norm of inverse(T). The true +C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by +C more than a factor of N. +C +C When SEPD is small, small changes in A, C can cause large changes +C in the solution of the equation. An approximate bound on the +C maximum relative error in the computed solution is +C +C EPS * norm(A)**2 / SEPD +C +C where EPS is the machine precision. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine MB03AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, October 1982. +C Based on DGELPD by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, TRANA + INTEGER INFO, LDA, LDC, LDU, LDWORK, N + DOUBLE PRECISION FERR, SCALE, SEPD +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ U( LDU, * ), WI( * ), WR( * ) +C .. +C .. Local Scalars .. + LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX + CHARACTER NOTRA, UPLO + INTEGER I, IERR, KASE, LWA, MINWRK, SDIM + DOUBLE PRECISION EST, SCALEF +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTA = LSAME( TRANA, 'N' ) +C + INFO = 0 + IF( .NOT.WANTBH .AND. .NOT.WANTSP .AND. .NOT.WANTX ) THEN + INFO = -1 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( WANTSP .AND. LDC.LT.1 .OR. + $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C +C Compute workspace. +C + IF( WANTX ) THEN + IF( NOFACT ) THEN + MINWRK = MAX( N*N, 3*N ) + ELSE + MINWRK = MAX( N*N, 2*N ) + END IF + ELSE + MINWRK = 2*N*N + 2*N + END IF + IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN + INFO = -18 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + SCALE = ONE + IF( WANTBH ) + $ FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + LWA = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LWA = INT( DWORK( 1 ) ) + END IF +C + IF( .NOT.WANTSP ) THEN +C +C Transform the right-hand side. +C Workspace: need N*N. +C + UPLO = 'U' + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U, + $ LDU, C, LDC, DWORK, LDWORK, INFO ) +C + DO 10 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 10 CONTINUE +C +C Solve the transformed equation. +C Workspace: 2*N. +C + CALL SB03MX( TRANA, N, A, LDA, C, LDC, SCALE, DWORK, INFO ) + IF( INFO.GT.0 ) + $ INFO = N + 1 +C +C Transform back the solution. +C + CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, + $ LDU, C, LDC, DWORK, LDWORK, INFO ) +C + DO 20 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 20 CONTINUE +C + END IF +C + IF( .NOT.WANTX ) THEN +C +C Estimate sepd(op(A),op(A)'). +C Workspace: 2*N*N + 2*N. +C + IF( NOTA ) THEN + NOTRA = 'T' + ELSE + NOTRA = 'N' + END IF +C + EST = ZERO + KASE = 0 +C REPEAT + 30 CONTINUE + CALL DLACON( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + CALL SB03MX( TRANA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK( 2*N*N + 1 ), IERR ) + ELSE + CALL SB03MX( NOTRA, N, A, LDA, DWORK, N, SCALEF, + $ DWORK( 2*N*N + 1 ), IERR ) + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + SEPD = SCALEF / EST +C + IF( WANTBH ) THEN +C +C Compute the estimate of the relative error. +C + FERR = DLAMCH( 'Precision' )* + $ DLANHS( 'Frobenius', N, A, LDA, DWORK )**2 / SEPD + END IF + END IF +C + DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) +C + RETURN +C *** Last line of SB03PD *** + END diff --git a/mex/sources/libslicot/SB03QD.f b/mex/sources/libslicot/SB03QD.f new file mode 100644 index 000000000..5f8ccf886 --- /dev/null +++ b/mex/sources/libslicot/SB03QD.f @@ -0,0 +1,676 @@ + SUBROUTINE SB03QD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, + $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the conditioning and compute an error bound on the +C solution of the real continuous-time Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = scale*C +C +C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The +C matrix A is N-by-N, the right hand side C and the solution X are +C N-by-N symmetric matrices, and scale is a given scale factor. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'B': Compute both the reciprocal condition number and +C the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix C is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved in the iterative estimation process, +C as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X and C. N >= 0. +C +C SCALE (input) DOUBLE PRECISION +C The scale factor, scale, set by a Lyapunov solver. +C 0 <= SCALE <= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of +C this array must contain the original matrix A. +C If FACT = 'F' and LYAPUN = 'R', A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; +C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then on entry the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of A. +C If FACT = 'N', then this array need not be set on input. +C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the +C leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of A. +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix C of the original Lyapunov equation (with +C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov +C equation (with matrix T), if LYAPUN = 'R'. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix C of the original Lyapunov equation (with +C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov +C equation (with matrix T), if LYAPUN = 'R'. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,N). +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C symmetric solution matrix X of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', the estimated quantity +C sep(op(A),-op(A)'). +C If N = 0, or X = 0, or JOB = 'E', SEP is not referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal +C condition number of the continuous-time Lyapunov equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'E', RCOND is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'B', an estimated forward error +C bound for the solution X. If XTRUE is the true solution, +C FERR bounds the magnitude of the largest entry in +C (X - XTRUE) divided by the magnitude of the largest entry +C in X. +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'C', FERR is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C If JOB = 'C', then +C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; +C LDWORK >= MAX(1,2*N*N,5*N), if FACT = 'N'. +C If JOB = 'E', or JOB = 'B', and LYAPUN = 'O', then +C LDWORK >= MAX(1,3*N*N), if FACT = 'F'; +C LDWORK >= MAX(1,3*N*N,5*N), if FACT = 'N'. +C If JOB = 'E', or JOB = 'B', and LYAPUN = 'R', then +C LDWORK >= MAX(1,3*N*N+N-1), if FACT = 'F'; +C LDWORK >= MAX(1,3*N*N+N-1,5*N), if FACT = 'N'. +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction to Schur canonical form (see +C LAPACK Library routine DGEES); on exit, the matrix +C T(i+1:N,i+1:N) contains the partially converged +C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) +C contain the real and imaginary parts, respectively, +C of the converged eigenvalues; this error is unlikely +C to appear; +C = N+1: if the matrices T and -T' have common or very +C close eigenvalues; perturbed values were used to +C solve Lyapunov equations, but the matrix T, if given +C (for FACT = 'F'), is unchanged. +C +C METHOD +C +C The condition number of the continuous-time Lyapunov equation is +C estimated as +C +C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), +C +C where Omega and Theta are linear operators defined by +C +C Omega(W) = op(A)'*W + W*op(A), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). +C +C The routine estimates the quantities +C +C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) +C +C and norm(Theta) using 1-norm condition estimators. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [1]. +C +C REFERENCES +C +C [1] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C When SEP is computed and it is zero, the routine returns +C immediately, with RCOND and FERR (if requested) set to 0 and 1, +C respectively. In this case, the equation is singular. +C +C CONTRIBUTORS +C +C P. Petkov, Tech. University of Sofia, December 1998. +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D0, + $ THREE = 3.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SCALE, SEP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ T( LDT, * ), U( LDU, * ), X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBB, JOBC, JOBE, LOWER, NOFACT, NOTRNA, + $ UPDATE + CHARACTER SJOB, TRANAT + INTEGER I, IABS, IRES, IWRK, IXBS, J, JJ, JX, LDW, NN, + $ SDIM, WRKOPT + DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, + $ TMAX, XANORM, XNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DGEES, DLACPY, DLASET, DSYR2K, MB01UD, + $ MB01UW, SB03QX, SB03QY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBB = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NN = N*N + IF( JOBC ) THEN + LDW = 2*NN + ELSE + LDW = 3*NN + END IF + IF( .NOT.( JOBC .OR. UPDATE ) ) + $ LDW = LDW + N - 1 +C + INFO = 0 + IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.1 .OR. + $ ( LDWORK.LT.LDW .AND. .NOT.NOFACT ) .OR. + $ ( LDWORK.LT.MAX( LDW, 5*N ) .AND. NOFACT ) ) THEN + INFO = -23 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03QD', -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 Compute the 1-norm of A or T. +C + IF( NOFACT .OR. UPDATE ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ELSE + ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) + END IF +C +C For the special case A = 0, set SEP and RCOND to 0. +C For the special case A = I, set SEP to 2 and RCOND to 1. +C A quick test is used in general. +C + IF( ANORM.EQ.ONE ) THEN + IF( NOFACT .OR. UPDATE ) THEN + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) + ELSE + CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) + IF( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), + $ N ) + END IF + DWORK( NN+1 ) = ONE + CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) + IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN + IF( .NOT.JOBE ) THEN + SEP = TWO + RCOND = ONE + END IF + IF( JOBC ) THEN + DWORK( 1 ) = DBLE( NN + 1 ) + RETURN + ELSE +C +C Set FERR for the special case A = I. +C + CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) +C + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DAXPY( N-J+1, -SCALE/TWO, C( J, J ), 1, + $ DWORK( (J-1)*N+J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DAXPY( J, -SCALE/TWO, C( 1, J ), 1, + $ DWORK( (J-1)*N+1 ), 1 ) + 20 CONTINUE + END IF +C + FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, + $ DWORK( NN+1 ) ) / XNORM ) + DWORK( 1 ) = DBLE( NN + N ) + RETURN + END IF + END IF +C + ELSE IF( ANORM.EQ.ZERO ) THEN + IF( .NOT.JOBE ) THEN + SEP = ZERO + RCOND = ZERO + END IF + IF( .NOT.JOBC ) + $ FERR = ONE + DWORK( 1 ) = DBLE( N ) + RETURN + END IF +C +C General case. +C + CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) +C +C Workspace usage. +C + IABS = 0 + IXBS = IABS + NN + IRES = IXBS + NN + IWRK = IRES + NN + WRKOPT = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A, A = U*T*U'. +C Workspace: need 5*N; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, + $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), + $ LDWORK-2*N, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N + END IF +C + IF( .NOT.JOBE ) THEN +C +C Estimate sep(op(A),-op(A)') = sep(op(T),-op(T)') and +C norm(Theta). +C Workspace 2*N*N. +C + CALL SB03QY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX, + $ SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) +C + WRKOPT = MAX( WRKOPT, 2*NN ) +C +C Return if the equation is singular. +C + IF( SEP.EQ.ZERO ) THEN + RCOND = ZERO + IF( JOBB ) + $ FERR = ONE + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN + END IF +C +C Estimate the reciprocal condition number. +C + TMAX = MAX( SEP, XNORM, ANORM ) + IF( TMAX.LE.ONE ) THEN + TEMP = SEP*XNORM + DENOM = ( SCALE*CNORM ) + ( SEP*ANORM )*THNORM + ELSE + TEMP = ( SEP / TMAX )*( XNORM / TMAX ) + DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + + $ ( ( SEP / TMAX )*( ANORM / TMAX ) )*THNORM + END IF + IF( TEMP.GE.DENOM ) THEN + RCOND = ONE + ELSE + RCOND = TEMP / DENOM + END IF + END IF +C + IF( .NOT.JOBC ) THEN +C +C Form a triangle of the residual matrix +C R = op(A)'*X + X*op(A) - scale*C, or +C R = op(T)'*X + X*op(T) - scale*C, +C exploiting the symmetry. +C Workspace 3*N*N. +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C + IF( UPDATE ) THEN +C + CALL DLACPY( UPLO, N, N, C, LDC, DWORK( IRES+1 ), N ) + CALL DSYR2K( UPLO, TRANAT, N, N, ONE, A, LDA, X, LDX, + $ -SCALE, DWORK( IRES+1 ), N ) + ELSE + CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, + $ DWORK( IRES+1 ), N, INFO ) + JJ = IRES + 1 + IF( LOWER ) THEN + DO 30 J = 1, N + CALL DAXPY( N-J+1, ONE, DWORK( JJ ), N, DWORK( JJ ), + $ 1 ) + CALL DAXPY( N-J+1, -SCALE, C( J, J ), 1, DWORK( JJ ), + $ 1 ) + JJ = JJ + N + 1 + 30 CONTINUE + ELSE + DO 40 J = 1, N + CALL DAXPY( J, ONE, DWORK( IRES+J ), N, DWORK( JJ ), + $ 1 ) + CALL DAXPY( J, -SCALE, C( 1, J ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + 40 CONTINUE + END IF + END IF +C + WRKOPT = MAX( WRKOPT, 3*NN ) +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) + EPSN = EPS*DBLE( N + 3 ) + TEMP = EPS*THREE*SCALE +C +C Add to abs(R) a term that takes account of rounding errors in +C forming R: +C abs(R) := abs(R) + EPS*(3*scale*abs(C) + +C (n+3)*(abs(op(A))'*abs(X) + abs(X)*abs(op(A)))), or +C abs(R) := abs(R) + EPS*(3*scale*abs(C) + +C (n+3)*(abs(op(T))'*abs(X) + abs(X)*abs(op(T)))), +C where EPS is the machine precision. +C + DO 60 J = 1, N + DO 50 I = 1, N + DWORK( IXBS+(J-1)*N+I ) = ABS( X( I, J ) ) + 50 CONTINUE + 60 CONTINUE +C + IF( LOWER ) THEN + DO 80 J = 1, N + DO 70 I = J, N + DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J = 1, N + DO 90 I = 1, J + DWORK( IRES+(J-1)*N+I ) = TEMP*ABS( C( I, J ) ) + + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + 90 CONTINUE + 100 CONTINUE + END IF +C + IF( UPDATE ) THEN +C +C Workspace 3*N*N. +C + DO 120 J = 1, N + DO 110 I = 1, N + DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) + 110 CONTINUE + 120 CONTINUE +C + CALL DSYR2K( UPLO, TRANAT, N, N, EPSN, DWORK( IABS+1 ), N, + $ DWORK( IXBS+1 ), N, ONE, DWORK( IRES+1 ), N ) + ELSE +C +C Workspace 3*N*N + N - 1. +C + DO 140 J = 1, N + DO 130 I = 1, MIN( J+1, N ) + DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) + 130 CONTINUE + 140 CONTINUE +C + CALL MB01UW( 'Left', TRANAT, N, N, EPSN, DWORK( IABS+1 ), + $ N, DWORK( IXBS+1), N, DWORK( IWRK+1 ), + $ LDWORK-IWRK, INFO ) + JJ = IRES + 1 + JX = IXBS + 1 + IF( LOWER ) THEN + DO 150 J = 1, N + CALL DAXPY( N-J+1, ONE, DWORK( JX ), N, DWORK( JX ), + $ 1 ) + CALL DAXPY( N-J+1, ONE, DWORK( JX ), 1, DWORK( JJ ), + $ 1 ) + JJ = JJ + N + 1 + JX = JX + N + 1 + 150 CONTINUE + ELSE + DO 160 J = 1, N + CALL DAXPY( J, ONE, DWORK( IXBS+J ), N, DWORK( JX ), + $ 1 ) + CALL DAXPY( J, ONE, DWORK( JX ), 1, DWORK( JJ ), 1 ) + JJ = JJ + N + JX = JX + N + 160 CONTINUE + END IF +C + WRKOPT = MAX( WRKOPT, 3*NN + N - 1 ) + END IF +C +C Compute forward error bound, using matrix norm estimator. +C Workspace 3*N*N. +C + XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) +C + CALL SB03QX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, + $ INFO ) + END IF +C + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of SB03QD *** + END diff --git a/mex/sources/libslicot/SB03QX.f b/mex/sources/libslicot/SB03QX.f new file mode 100644 index 000000000..255ca13a0 --- /dev/null +++ b/mex/sources/libslicot/SB03QX.f @@ -0,0 +1,394 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB03QY.f b/mex/sources/libslicot/SB03QY.f new file mode 100644 index 000000000..63f41f5b8 --- /dev/null +++ b/mex/sources/libslicot/SB03QY.f @@ -0,0 +1,443 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB03RD.f b/mex/sources/libslicot/SB03RD.f new file mode 100644 index 000000000..0398a3abc --- /dev/null +++ b/mex/sources/libslicot/SB03RD.f @@ -0,0 +1,404 @@ + SUBROUTINE SB03RD( JOB, FACT, TRANA, N, A, LDA, U, LDU, C, LDC, + $ SCALE, SEP, FERR, WR, WI, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = scale*C +C +C and/or estimate the separation between the matrices op(A) and +C -op(A)', where op(A) = A or A' (A**T) and C is symmetric (C = C'). +C (A' denotes the transpose of the matrix A.) A is N-by-N, the right +C hand side C and the solution X are N-by-N, and scale is an output +C scale factor, set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'B': Compute both the solution and the separation. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U. +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix A. If FACT = 'F', then A contains +C an upper quasi-triangular matrix in Schur canonical form. +C On exit, if INFO = 0 or INFO = N+1, the leading N-by-N +C part of this array contains the upper quasi-triangular +C matrix in Schur canonical form from the Shur factorization +C of A. The contents of array A is not modified if +C FACT = 'F'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If FACT = 'F', then U is an input argument and on entry +C it must contain the orthogonal matrix U from the real +C Schur factorization of A. +C If FACT = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO = N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry with JOB = 'X' or 'B', the leading N-by-N part of +C this array must contain the symmetric matrix C. +C On exit with JOB = 'X' or 'B', if INFO = 0 or INFO = N+1, +C the leading N-by-N part of C has been overwritten by the +C symmetric solution matrix X. +C If JOB = 'S', C is not referenced. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0 or INFO = N+1, SEP +C contains the estimated separation of the matrices op(A) +C and -op(A)'. +C If JOB = 'X' or N = 0, SEP is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0 or INFO = N+1, FERR contains +C an estimated forward error bound for the solution X. +C If XTRUE is the true solution, FERR bounds the relative +C error in the computed solution, measured in the Frobenius +C norm: norm(X - XTRUE)/norm(XTRUE). +C If JOB = 'X' or JOB = 'S', FERR is not referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of the +C eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 1 and +C If JOB = 'X' then +C If FACT = 'F', LDWORK >= N*N; +C If FACT = 'N', LDWORK >= MAX(N*N,3*N). +C If JOB = 'S' or JOB = 'B' then +C If FACT = 'F', LDWORK >= 2*N*N; +C If FACT = 'N', LDWORK >= MAX(2*N*N,3*N). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute all +C the eigenvalues (see LAPACK Library routine DGEES); +C elements i+1:n of WR and WI contain eigenvalues +C which have converged, and A contains the partially +C converged Schur form; +C = N+1: if the matrices A and -A' have common or very +C close eigenvalues; perturbed values were used to +C solve the equation (but the matrix A is unchanged). +C +C METHOD +C +C After reducing matrix A to real Schur canonical form (if needed), +C the Bartels-Stewart algorithm is used. A set of equivalent linear +C algebraic systems of equations of order at most four are formed +C and solved using Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C FURTHER COMMENTS +C +C SEP is defined as the separation of op(A) and -op(A)': +C +C sep( op(A), -op(A)' ) = sigma_min( T ) +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( I(N), op(A)' ) + kprod( op(A), I(N) ). +C +C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker +C product. The program estimates sigma_min(T) by the reciprocal of +C an estimate of the 1-norm of inverse(T). The true reciprocal +C 1-norm of inverse(T) cannot differ from sigma_min(T) by more +C than a factor of N. +C +C When SEP is small, small changes in A, C can cause large changes +C in the solution of the equation. An approximate bound on the +C maximum relative error in the computed solution is +C +C EPS * norm(A) / SEP +C +C where EPS is the machine precision. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997. +C Supersedes Release 2.0 routine MB03AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, October 1982. +C Based on DGELYP by P. Petkov, Tech. University of Sofia, September +C 1993. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, TRANA + INTEGER INFO, LDA, LDC, LDU, LDWORK, N + DOUBLE PRECISION FERR, SCALE, SEP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ U( LDU, * ), WI( * ), WR( * ) +C .. +C .. Local Scalars .. + LOGICAL NOFACT, NOTA, WANTBH, WANTSP, WANTX + CHARACTER NOTRA, UPLO + INTEGER I, IERR, KASE, LWA, MINWRK, SDIM + DOUBLE PRECISION EST, SCALEF +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANHS + EXTERNAL DLAMCH, DLANHS, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DLACON, MB01RD, SB03MY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTA = LSAME( TRANA, 'N' ) +C + INFO = 0 + IF( .NOT.WANTSP .AND. .NOT.WANTBH .AND. .NOT.WANTX ) THEN + INFO = -1 + ELSE IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( WANTSP .AND. LDC.LT.1 .OR. + $ .NOT.WANTSP .AND. LDC.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C +C Compute workspace. +C + IF( WANTX ) THEN + IF( NOFACT ) THEN + MINWRK = MAX( N*N, 3*N ) + ELSE + MINWRK = N*N + END IF + ELSE + IF( NOFACT ) THEN + MINWRK = MAX( 2*N*N, 3*N ) + ELSE + MINWRK = 2*N*N + END IF + END IF + IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN + INFO = -18 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + SCALE = ONE + IF( WANTBH ) + $ FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + LWA = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LWA = INT( DWORK( 1 ) ) + END IF +C + IF( .NOT.WANTSP ) THEN +C +C Transform the right-hand side. +C Workspace: need N*N. +C + UPLO = 'U' + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, C, LDC, U, + $ LDU, C, LDC, DWORK, LDWORK, INFO ) +C + DO 10 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 10 CONTINUE +C +C Solve the transformed equation. +C + CALL SB03MY( TRANA, N, A, LDA, C, LDC, SCALE, INFO ) + IF( INFO.GT.0 ) + $ INFO = N + 1 +C +C Transform back the solution. +C + CALL MB01RD( UPLO, 'No transpose', N, N, ZERO, ONE, C, LDC, U, + $ LDU, C, LDC, DWORK, LDWORK, INFO ) +C + DO 20 I = 2, N + CALL DCOPY( I-1, C(1,I), 1, C(I,1), LDC ) + 20 CONTINUE +C + END IF +C + IF( .NOT.WANTX ) THEN +C +C Estimate sep(op(A),-op(A)'). +C Workspace: 2*N*N. +C + IF( NOTA ) THEN + NOTRA = 'T' + ELSE + NOTRA = 'N' + END IF +C + EST = ZERO + KASE = 0 +C REPEAT + 30 CONTINUE + CALL DLACON( N*N, DWORK( N*N+1 ), DWORK, IWORK, EST, KASE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.1 ) THEN + CALL SB03MY( TRANA, N, A, LDA, DWORK, N, SCALEF, IERR ) + ELSE + CALL SB03MY( NOTRA, N, A, LDA, DWORK, N, SCALEF, IERR ) + END IF + GO TO 30 + END IF +C UNTIL KASE = 0 +C + SEP = SCALEF / EST +C + IF( WANTBH ) THEN +C +C Compute the estimate of the relative error. +C + FERR = DLAMCH( 'Precision' )* + $ DLANHS( 'Frobenius', N, A, LDA, DWORK ) / SEP + END IF + END IF +C + DWORK( 1 ) = DBLE( MAX( LWA, MINWRK ) ) +C + RETURN +C *** Last line of SB03RD *** + END diff --git a/mex/sources/libslicot/SB03SD.f b/mex/sources/libslicot/SB03SD.f new file mode 100644 index 000000000..bcf122954 --- /dev/null +++ b/mex/sources/libslicot/SB03SD.f @@ -0,0 +1,674 @@ + SUBROUTINE SB03SD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, + $ RCOND, FERR, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To estimate the conditioning and compute an error bound on the +C solution of the real discrete-time Lyapunov matrix equation +C +C op(A)'*X*op(A) - X = scale*C +C +C where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The +C matrix A is N-by-N, the right hand side C and the solution X are +C N-by-N symmetric matrices, and scale is a given scale factor. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'B': Compute both the reciprocal condition number and +C the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix C is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original Lyapunov equations +C should be solved in the iterative estimation process, +C as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X and C. N >= 0. +C +C SCALE (input) DOUBLE PRECISION +C The scale factor, scale, set by a Lyapunov solver. +C 0 <= SCALE <= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or LYAPUN = 'O', the leading N-by-N part of +C this array must contain the original matrix A. +C If FACT = 'F' and LYAPUN = 'R', A is not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O'; +C LDA >= 1, if FACT = 'F' and LYAPUN = 'R'. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then on entry the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of A. +C If FACT = 'N', then this array need not be set on input. +C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the +C leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of A. +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If UPLO = 'U', the leading N-by-N upper triangular part of +C this array must contain the upper triangular part of the +C matrix C of the original Lyapunov equation (with +C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov +C equation (with matrix T), if LYAPUN = 'R'. +C If UPLO = 'L', the leading N-by-N lower triangular part of +C this array must contain the lower triangular part of the +C matrix C of the original Lyapunov equation (with +C matrix A), if LYAPUN = 'O', or of the reduced Lyapunov +C equation (with matrix T), if LYAPUN = 'R'. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,N). +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C symmetric solution matrix X of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C The array X is modified internally, but restored on exit. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SEPD (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', the estimated quantity +C sepd(op(A),op(A)'). +C If N = 0, or X = 0, or JOB = 'E', SEPD is not referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'B', an estimate of the reciprocal +C condition number of the discrete-time Lyapunov equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'E', RCOND is not referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'B', an estimated forward error +C bound for the solution X. If XTRUE is the true solution, +C FERR bounds the magnitude of the largest entry in +C (X - XTRUE) divided by the magnitude of the largest entry +C in X. +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'C', FERR is not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 1, if N = 0; else, +C LDWORK >= MAX(3,2*N*N) + N*N, if JOB = 'C', +C FACT = 'F'; +C LDWORK >= MAX(MAX(3,2*N*N) + N*N, 5*N), if JOB = 'C', +C FACT = 'N'; +C LDWORK >= MAX(3,2*N*N) + N*N + 2*N, if JOB = 'E', or +C JOB = 'B'. +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction to Schur canonical form (see +C LAPACK Library routine DGEES); on exit, the matrix +C T(i+1:N,i+1:N) contains the partially converged +C Schur form, and DWORK(i+1:N) and DWORK(N+i+1:2*N) +C contain the real and imaginary parts, respectively, +C of the converged eigenvalues; this error is unlikely +C to appear; +C = N+1: if the matrix T has almost reciprocal eigenvalues; +C perturbed values were used to solve Lyapunov +C equations, but the matrix T, if given (for +C FACT = 'F'), is unchanged. +C +C METHOD +C +C The condition number of the discrete-time Lyapunov equation is +C estimated as +C +C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), +C +C where Omega and Theta are linear operators defined by +C +C Omega(W) = op(A)'*W*op(A) - W, +C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). +C +C The routine estimates the quantities +C +C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) +C +C and norm(Theta) using 1-norm condition estimators. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [1]. +C +C REFERENCES +C +C [1] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The option LYAPUN = 'R' may occasionally produce slightly worse +C or better estimates, and it is much faster than the option 'O'. +C When SEPD is computed and it is zero, the routine returns +C immediately, with RCOND and FERR (if requested) set to 0 and 1, +C respectively. In this case, the equation is singular. +C +C CONTRIBUTORS +C +C P. Petkov, Tech. University of Sofia, December 1998. +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 2003. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, THREE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, THREE = 3.0D0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SCALE, SEPD +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ T( LDT, * ), U( LDU, * ), X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBB, JOBC, JOBE, LOWER, NOFACT, NOTRNA, + $ UPDATE + CHARACTER SJOB, TRANAT + INTEGER I, IABS, IRES, IWRK, IXMA, J, LDW, NN, SDIM, + $ WRKOPT + DOUBLE PRECISION ANORM, CNORM, DENOM, EPS, EPSN, TEMP, THNORM, + $ TMAX, XANORM, XNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + DOUBLE PRECISION DLAMCH, DLANGE, DLANHS, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANHS, DLANSY, LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEES, DGEMM, DLACPY, DLASET, + $ MA02ED, MB01RU, MB01RX, MB01RY, MB01UD, SB03SX, + $ SB03SY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBB = LSAME( JOB, 'B' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C + NN = N*N + LDW = MAX( 3, 2*NN ) + NN +C + INFO = 0 + IF( .NOT.( JOBB .OR. JOBC .OR. JOBE ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( UPDATE .OR. NOFACT ) ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.1 .OR. + $ ( LDWORK.LT.LDW .AND. JOBC .AND. .NOT.NOFACT ) .OR. + $ ( LDWORK.LT.MAX( LDW, 5*N ) .AND. JOBC .AND. NOFACT ) .OR. + $ ( LDWORK.LT.( LDW + 2*N ) .AND. .NOT.JOBC ) ) THEN + INFO = -23 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03SD', -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 Compute the 1-norm of A or T. +C + IF( NOFACT .OR. UPDATE ) THEN + ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ELSE + ANORM = DLANHS( '1-norm', N, T, LDT, DWORK ) + END IF +C +C For the special case A = I, set SEPD and RCOND to 0. +C For the special case A = 0, set SEPD and RCOND to 1. +C A quick test is used in general. +C + IF( ANORM.EQ.ONE ) THEN + IF( NOFACT .OR. UPDATE ) THEN + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) + ELSE + CALL DLACPY( 'Full', N, N, T, LDT, DWORK, N ) + IF( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, DWORK( 3 ), + $ N ) + END IF + DWORK( NN+1 ) = ONE + CALL DAXPY( N, -ONE, DWORK( NN+1 ), 0, DWORK, N+1 ) + IF( DLANGE( 'Max', N, N, DWORK, N, DWORK ).EQ.ZERO ) THEN + IF( .NOT.JOBE ) THEN + SEPD = ZERO + RCOND = ZERO + END IF + IF( .NOT.JOBC ) + $ FERR = ONE + DWORK( 1 ) = DBLE( NN + 1 ) + RETURN + END IF +C + ELSE IF( ANORM.EQ.ZERO ) THEN + IF( .NOT.JOBE ) THEN + SEPD = ONE + RCOND = ONE + END IF + IF( JOBC ) THEN + DWORK( 1 ) = DBLE( N ) + RETURN + ELSE +C +C Set FERR for the special case A = 0. +C + CALL DLACPY( UPLO, N, N, X, LDX, DWORK, N ) +C + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DAXPY( N-J+1, SCALE, C( J, J ), 1, + $ DWORK( (J-1)*N+J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DAXPY( J, SCALE, C( 1, J ), 1, + $ DWORK( (J-1)*N+1 ), 1 ) + 20 CONTINUE + END IF +C + FERR = MIN( ONE, DLANSY( '1-norm', UPLO, N, DWORK, N, + $ DWORK( NN+1 ) ) / XNORM ) + DWORK( 1 ) = DBLE( NN + N ) + RETURN + END IF + END IF +C +C General case. +C + CNORM = DLANSY( '1-norm', UPLO, N, C, LDC, DWORK ) +C +C Workspace usage. +C + IABS = NN + IXMA = MAX( 3, 2*NN ) + IRES = IXMA + IWRK = IXMA + NN + WRKOPT = 0 +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A, A = U*T*U'. +C Workspace: need 5*N; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, + $ DWORK( 1 ), DWORK( N+1 ), U, LDU, DWORK( 2*N+1 ), + $ LDWORK-2*N, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = INT( DWORK( 2*N+1 ) ) + 2*N + END IF +C +C Compute X*op(A) or X*op(T). +C + IF( UPDATE ) THEN + CALL DGEMM( 'NoTranspose', TRANA, N, N, N, ONE, X, LDX, A, LDA, + $ ZERO, DWORK( IXMA+1 ), N ) + ELSE + CALL MB01UD( 'Right', TRANA, N, N, ONE, T, LDT, X, LDX, + $ DWORK( IXMA+1 ), N, INFO ) + END IF +C + IF( .NOT.JOBE ) THEN +C +C Estimate sepd(op(A),op(A)') = sepd(op(T),op(T)') and +C norm(Theta). +C Workspace max(3,2*N*N) + N*N. +C + CALL SB03SY( 'Both', TRANA, LYAPUN, N, T, LDT, U, LDU, + $ DWORK( IXMA+1 ), N, SEPD, THNORM, IWORK, DWORK, + $ IXMA, INFO ) +C + WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN ) +C +C Return if the equation is singular. +C + IF( SEPD.EQ.ZERO ) THEN + RCOND = ZERO + IF( JOBB ) + $ FERR = ONE + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN + END IF +C +C Estimate the reciprocal condition number. +C + TMAX = MAX( SEPD, XNORM, ANORM ) + IF( TMAX.LE.ONE ) THEN + TEMP = SEPD*XNORM + DENOM = ( SCALE*CNORM ) + ( SEPD*ANORM )*THNORM + ELSE + TEMP = ( SEPD / TMAX )*( XNORM / TMAX ) + DENOM = ( ( SCALE / TMAX )*( CNORM / TMAX ) ) + + $ ( ( SEPD / TMAX )*( ANORM / TMAX ) )*THNORM + END IF + IF( TEMP.GE.DENOM ) THEN + RCOND = ONE + ELSE + RCOND = TEMP / DENOM + END IF + END IF +C + IF( .NOT.JOBC ) THEN +C +C Form a triangle of the residual matrix +C R = scale*C + X - op(A)'*X*op(A), or +C R = scale*C + X - op(T)'*X*op(T), +C exploiting the symmetry. For memory savings, R is formed in the +C leading N-by-N upper/lower triangular part of DWORK, and it is +C finally moved in the location where X*op(A) or X*op(T) was +C stored, freeing workspace for the SB03SX call. +C + IF( NOTRNA ) THEN + TRANAT = 'T' + ELSE + TRANAT = 'N' + END IF +C + CALL DLACPY( UPLO, N, N, C, LDC, DWORK, N ) +C + IF( UPDATE ) THEN + CALL MB01RX( 'Left', UPLO, TRANAT, N, N, SCALE, -ONE, DWORK, + $ N, A, LDA, DWORK( IXMA+1 ), N, INFO ) + ELSE + CALL MB01RY( 'Left', UPLO, TRANAT, N, SCALE, -ONE, DWORK, N, + $ T, LDT, DWORK( IXMA+1 ), N, DWORK( IWRK+1 ), + $ INFO ) + END IF +C + IF( LOWER ) THEN + DO 30 J = 1, N + CALL DAXPY( N-J+1, ONE, X( J, J ), 1, DWORK( (J-1)*N+J ), + $ 1 ) + 30 CONTINUE + ELSE + DO 40 J = 1, N + CALL DAXPY( J, ONE, X( 1, J ), 1, DWORK( (J-1)*N+1 ), 1 ) + 40 CONTINUE + END IF +C + CALL DLACPY( UPLO, N, N, DWORK, N, DWORK( IRES+1 ), N ) +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) + EPSN = EPS*DBLE( 2*N + 2 ) +C +C Add to abs(R) a term that takes account of rounding errors in +C forming R: +C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + +C 2*(n+1)*abs(op(A))'*abs(X)*abs(op(A))), or +C abs(R) := abs(R) + EPS*(3*scale*abs(C) + 3*abs(X) + +C 2*(n+1)*abs(op(T))'*abs(X)*abs(op(T))), +C where EPS is the machine precision. +C Workspace max(3,2*N*N) + N*N + 2*N. +C Note that the lower or upper triangular part of X specified by +C UPLO is used as workspace, but it is finally restored. +C + IF( UPDATE ) THEN + DO 60 J = 1, N + DO 50 I = 1, N + DWORK( IABS+(J-1)*N+I ) = ABS( A( I, J ) ) + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80 J = 1, N + DO 70 I = 1, MIN( J+1, N ) + DWORK( IABS+(J-1)*N+I ) = ABS( T( I, J ) ) + 70 CONTINUE + 80 CONTINUE + END IF +C + CALL DCOPY( N, X, LDX+1, DWORK( IWRK+1 ), 1 ) +C + IF( LOWER ) THEN + DO 100 J = 1, N + DO 90 I = J, N + TEMP = ABS( X( I, J ) ) + X( I, J ) = TEMP + DWORK( IRES+(J-1)*N+I ) = + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + + $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) + 90 CONTINUE + 100 CONTINUE + ELSE + DO 120 J = 1, N + DO 110 I = 1, J + TEMP = ABS( X( I, J ) ) + X( I, J ) = TEMP + DWORK( IRES+(J-1)*N+I ) = + $ ABS( DWORK( IRES+(J-1)*N+I ) ) + + $ EPS*THREE*( SCALE*ABS( C( I, J ) ) + TEMP ) + 110 CONTINUE + 120 CONTINUE + END IF +C + IF( UPDATE ) THEN + CALL MB01RU( UPLO, TRANAT, N, N, ONE, EPSN, DWORK( IRES+1 ), + $ N, DWORK( IABS+1 ), N, X, LDX, DWORK, NN, + $ INFO ) + ELSE +C +C Compute W = abs(X)*abs(op(T)), and then premultiply by +C abs(T)' and add in the result. +C + CALL MB01UD( 'Right', TRANA, N, N, ONE, DWORK( IABS+1 ), N, + $ X, LDX, DWORK, N, INFO ) + CALL MB01RY( 'Left', UPLO, TRANAT, N, ONE, EPSN, + $ DWORK( IRES+1 ), N, DWORK( IABS+1 ), N, DWORK, + $ N, DWORK( IWRK+N+1 ), INFO ) + END IF +C + WRKOPT = MAX( WRKOPT, MAX( 3, 2*NN ) + NN + 2*N ) +C +C Restore X. +C + CALL DCOPY( N, DWORK( IWRK+1 ), 1, X, LDX+1 ) + IF( LOWER ) THEN + CALL MA02ED( 'Upper', N, X, LDX ) + ELSE + CALL MA02ED( 'Lower', N, X, LDX ) + END IF +C +C Compute forward error bound, using matrix norm estimator. +C Workspace max(3,2*N*N) + N*N. +C + XANORM = DLANSY( 'Max', UPLO, N, X, LDX, DWORK ) +C + CALL SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU, + $ DWORK( IRES+1 ), N, FERR, IWORK, DWORK, IRES, + $ INFO ) + END IF +C + DWORK( 1 ) = DBLE( WRKOPT ) + RETURN +C +C *** Last line of SB03SD *** + END diff --git a/mex/sources/libslicot/SB03SX.f b/mex/sources/libslicot/SB03SX.f new file mode 100644 index 000000000..58078b80d --- /dev/null +++ b/mex/sources/libslicot/SB03SX.f @@ -0,0 +1,398 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB03SY.f b/mex/sources/libslicot/SB03SY.f new file mode 100644 index 000000000..8cdc0c9bb --- /dev/null +++ b/mex/sources/libslicot/SB03SY.f @@ -0,0 +1,451 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB03TD.f b/mex/sources/libslicot/SB03TD.f new file mode 100644 index 000000000..a1a81961f --- /dev/null +++ b/mex/sources/libslicot/SB03TD.f @@ -0,0 +1,545 @@ + SUBROUTINE SB03TD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, + $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real continuous-time Lyapunov matrix equation +C +C op(A)'*X + X*op(A) = scale*C, +C +C estimate the conditioning, and compute an error bound on the +C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, +C the right hand side C and the solution X are N-by-N symmetric +C matrices (C = C', X = X'), and scale is an output scale factor, +C set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'A': Compute all: the solution, separation, reciprocal +C condition number, and the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix C is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original or "reduced" +C Lyapunov equations should be solved, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C This means that a real Schur form T of A appears +C in the equation, instead of A. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C SCALE (input or output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'E', SCALE is an input argument: +C the scale factor, set by a Lyapunov solver. +C 0 <= SCALE <= 1. +C If JOB = 'X' or JOB = 'A', SCALE is an output argument: +C the scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C If JOB = 'S', this argument is not used. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the +C leading N-by-N part of this array must contain the +C original matrix A. +C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and +C JOB <> 'X'; +C LDA >= 1, otherwise. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then on entry the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of A. +C If FACT = 'N', then this array need not be set on input. +C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the +C leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C The contents of array T is not modified if FACT = 'F'. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of A. +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the matrix C of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the matrix C of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C The remaining strictly triangular part of this array is +C used as workspace. +C If JOB = 'X', then this array may be identified with X +C in the call of this routine. +C If JOB = 'S', the array C is not referenced. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C X (input or output) DOUBLE PRECISION array, dimension +C (LDX,N) +C If JOB = 'C' or 'E', then X is an input argument and on +C entry, the leading N-by-N part of this array must contain +C the symmetric solution matrix X of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C If JOB = 'X' or 'A', then X is an output argument and on +C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part +C of this array contains the symmetric solution matrix X of +C of the original Lyapunov equation (with matrix A), if +C LYAPUN = 'O', or of the reduced Lyapunov equation (with +C matrix T), if LYAPUN = 'R'. +C If JOB = 'S', the array X is not referenced. +C +C LDX INTEGER +C The leading dimension of the array X. +C LDX >= 1, if JOB = 'S'; +C LDX >= MAX(1,N), otherwise. +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or +C INFO = N+1, SEP contains the estimated separation of the +C matrices op(A) and -op(A)', sep(op(A),-op(A)'). +C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEP is not +C referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal +C condition number of the continuous-time Lyapunov equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not +C referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, +C FERR contains an estimated forward error bound for the +C solution X. If XTRUE is the true solution, FERR bounds the +C relative error in the computed solution, measured in the +C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not +C referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of the +C eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If JOB = 'X', then +C LDWORK >= MAX(1,N*N), if FACT = 'F'; +C LDWORK >= MAX(1,MAX(N*N,3*N)), if FACT = 'N'. +C If JOB = 'S' or JOB = 'C', then +C LDWORK >= MAX(1,2*N*N), if FACT = 'F'; +C LDWORK >= MAX(1,2*N*N,3*N), if FACT = 'N'. +C If JOB = 'E', or JOB = 'A', and LYAPUN = 'O', then +C LDWORK >= MAX(1,3*N*N); +C If JOB = 'E', or JOB = 'A', and LYAPUN = 'R', then +C LDWORK >= MAX(1,3*N*N+N-1). +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction to Schur canonical form (see +C LAPACK Library routine DGEES); on exit, the matrix +C T(i+1:N,i+1:N) contains the partially converged +C Schur form, and the elements i+1:n of WR and WI +C contain the real and imaginary parts, respectively, +C of the converged eigenvalues; this error is unlikely +C to appear; +C = N+1: if the matrices T and -T' have common or very +C close eigenvalues; perturbed values were used to +C solve Lyapunov equations, but the matrix T, if given +C (for FACT = 'F'), is unchanged. +C +C METHOD +C +C After reducing matrix A to real Schur canonical form (if needed), +C the Bartels-Stewart algorithm is used. A set of equivalent linear +C algebraic systems of equations of order at most four are formed +C and solved using Gaussian elimination with complete pivoting. +C +C The condition number of the continuous-time Lyapunov equation is +C estimated as +C +C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), +C +C where Omega and Theta are linear operators defined by +C +C Omega(W) = op(A)'*W + W*op(A), +C Theta(W) = inv(Omega(op(W)'*X + X*op(W))). +C +C The routine estimates the quantities +C +C sep(op(A),-op(A)') = 1 / norm(inv(Omega)) +C +C and norm(Theta) using 1-norm condition estimators. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [2]. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The separation of op(A) and -op(A)' can also be defined as +C +C sep( op(A), -op(A)' ) = sigma_min( T ), +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ). +C +C I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker +C product. The routine estimates sigma_min(T) by the reciprocal of +C an estimate of the 1-norm of inverse(T). The true reciprocal +C 1-norm of inverse(T) cannot differ from sigma_min(T) by more +C than a factor of N. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C This is an extended and improved version of Release 3.0 routine +C SB03RD. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SCALE, SEP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, + $ NOTRNA, UPDATE + CHARACTER CFACT, JOBL, SJOB + INTEGER LDW, NN, SDIM + DOUBLE PRECISION THNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MY, + $ SB03QD, SB03QY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode option parameters. +C + JOBX = LSAME( JOB, 'X' ) + JOBS = LSAME( JOB, 'S' ) + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBA = LSAME( JOB, 'A' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C +C Compute workspace. +C + NN = N*N + IF( JOBX ) THEN + LDW = NN + ELSE IF( JOBS .OR. JOBC ) THEN + LDW = 2*NN + ELSE + LDW = 3*NN + END IF + IF( ( JOBE .OR. JOBA ).AND. .NOT.UPDATE ) + $ LDW = LDW + N - 1 + IF( NOFACT ) + $ LDW = MAX( LDW, 3*N ) +C +C Test the scalar input parameters. +C + INFO = 0 + IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( ( JOBC .OR. JOBE ) .AND. + $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. + $ NOFACT ) ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.1 .OR. ( LDWORK.LT.LDW ) ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( JOBX .OR. JOBA ) + $ SCALE = ONE + IF( JOBC .OR. JOBA ) + $ RCOND = ONE + IF( JOBE .OR. JOBA ) + $ FERR = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, + $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + CFACT = 'F' + ELSE + CFACT = FACT + END IF +C + IF( JOBX .OR. JOBA ) THEN +C +C Copy the right-hand side in X. +C + CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) +C + IF( UPDATE ) THEN +C +C Transform the right-hand side. +C Workspace: need N*N. +C + CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, + $ LDU, X, LDX, DWORK, LDWORK, INFO ) + CALL DSCAL( N, HALF, X, LDX+1 ) + END IF +C +C Fill in the remaining triangle of X. +C + CALL MA02ED( UPLO, N, X, LDX ) +C +C Solve the transformed equation. +C + CALL SB03MY( TRANA, N, T, LDT, X, LDX, SCALE, INFO ) + IF( INFO.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back the solution. +C + CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, + $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) + CALL DSCAL( N, HALF, X, LDX+1 ) +C +C Fill in the remaining triangle of X. +C + CALL MA02ED( UPLO, N, X, LDX ) + END IF + END IF +C + IF( JOBS ) THEN +C +C Estimate sep(op(A),-op(A)'). +C Workspace: 2*N*N. +C + CALL SB03QY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, X, + $ LDX, SEP, THNORM, IWORK, DWORK, LDWORK, INFO ) +C + ELSE IF( .NOT.JOBX ) THEN +C +C Estimate the reciprocal condition and/or the error bound. +C Workspace: 2*N*N, if JOB = 'C'; +C 3*N*N + a*(N-1), where: +C a = 1, if JOB = 'E' or JOB = 'A', and LYAPUN = 'R'; +C a = 0, otherwise. +C + IF( JOBA ) THEN + JOBL = 'B' + ELSE + JOBL = JOB + END IF + CALL SB03QD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEP, RCOND, + $ FERR, IWORK, DWORK, LDWORK, INFO ) + LDW = MAX( LDW, INT( DWORK( 1 ) ) ) + END IF +C + DWORK( 1 ) = DBLE( LDW ) +C + RETURN +C *** Last line of SB03TD *** + END diff --git a/mex/sources/libslicot/SB03UD.f b/mex/sources/libslicot/SB03UD.f new file mode 100644 index 000000000..f09443eb7 --- /dev/null +++ b/mex/sources/libslicot/SB03UD.f @@ -0,0 +1,554 @@ + SUBROUTINE SB03UD( JOB, FACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, + $ RCOND, FERR, WR, WI, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve the real discrete-time Lyapunov matrix equation +C +C op(A)'*X*op(A) - X = scale*C, +C +C estimate the conditioning, and compute an error bound on the +C solution X, where op(A) = A or A' (A**T), the matrix A is N-by-N, +C the right hand side C and the solution X are N-by-N symmetric +C matrices (C = C', X = X'), and scale is an output scale factor, +C set less than or equal to 1 to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Specifies the computation to be performed, as follows: +C = 'X': Compute the solution only; +C = 'S': Compute the separation only; +C = 'C': Compute the reciprocal condition number only; +C = 'E': Compute the error bound only; +C = 'A': Compute all: the solution, separation, reciprocal +C condition number, and the error bound. +C +C FACT CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, T and U (if LYAPUN = 'O') contain the +C factors from the real Schur factorization of the +C matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in T and U (if +C LYAPUN = 'O'). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C UPLO CHARACTER*1 +C Specifies which part of the symmetric matrix C is to be +C used, as follows: +C = 'U': Upper triangular part; +C = 'L': Lower triangular part. +C +C LYAPUN CHARACTER*1 +C Specifies whether or not the original or "reduced" +C Lyapunov equations should be solved, as follows: +C = 'O': Solve the original Lyapunov equations, updating +C the right-hand sides and solutions with the +C matrix U, e.g., X <-- U'*X*U; +C = 'R': Solve reduced Lyapunov equations only, without +C updating the right-hand sides and solutions. +C This means that a real Schur form T of A appears +C in the equation, instead of A. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, X, and C. N >= 0. +C +C SCALE (input or output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'E', SCALE is an input argument: +C the scale factor, set by a Lyapunov solver. +C 0 <= SCALE <= 1. +C If JOB = 'X' or JOB = 'A', SCALE is an output argument: +C the scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C If JOB = 'S', this argument is not used. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If FACT = 'N' or (LYAPUN = 'O' and JOB <> 'X'), the +C leading N-by-N part of this array must contain the +C original matrix A. +C If FACT = 'F' and (LYAPUN = 'R' or JOB = 'X'), A is +C not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. +C LDA >= MAX(1,N), if FACT = 'N' or LYAPUN = 'O' and +C JOB <> 'X'; +C LDA >= 1, otherwise. +C +C T (input/output) DOUBLE PRECISION array, dimension +C (LDT,N) +C If FACT = 'F', then on entry the leading N-by-N upper +C Hessenberg part of this array must contain the upper +C quasi-triangular matrix T in Schur canonical form from a +C Schur factorization of A. +C If FACT = 'N', then this array need not be set on input. +C On exit, (if INFO = 0 or INFO = N+1, for FACT = 'N') the +C leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix T in Schur +C canonical form from a Schur factorization of A. +C The contents of array T is not modified if FACT = 'F'. +C +C LDT INTEGER +C The leading dimension of the array T. LDT >= MAX(1,N). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,N) +C If LYAPUN = 'O' and FACT = 'F', then U is an input +C argument and on entry, the leading N-by-N part of this +C array must contain the orthogonal matrix U from a real +C Schur factorization of A. +C If LYAPUN = 'O' and FACT = 'N', then U is an output +C argument and on exit, if INFO = 0 or INFO = N+1, it +C contains the orthogonal N-by-N matrix from a real Schur +C factorization of A. +C If LYAPUN = 'R', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of the array U. +C LDU >= 1, if LYAPUN = 'R'; +C LDU >= MAX(1,N), if LYAPUN = 'O'. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C If JOB <> 'S' and UPLO = 'U', the leading N-by-N upper +C triangular part of this array must contain the upper +C triangular part of the matrix C of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C If JOB <> 'S' and UPLO = 'L', the leading N-by-N lower +C triangular part of this array must contain the lower +C triangular part of the matrix C of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C The remaining strictly triangular part of this array is +C used as workspace. +C If JOB = 'X', then this array may be identified with X +C in the call of this routine. +C If JOB = 'S', the array C is not referenced. +C +C LDC INTEGER +C The leading dimension of the array C. +C LDC >= 1, if JOB = 'S'; +C LDC >= MAX(1,N), otherwise. +C +C X (input or output) DOUBLE PRECISION array, dimension +C (LDX,N) +C If JOB = 'C' or 'E', then X is an input argument and on +C entry, the leading N-by-N part of this array must contain +C the symmetric solution matrix X of the original Lyapunov +C equation (with matrix A), if LYAPUN = 'O', or of the +C reduced Lyapunov equation (with matrix T), if +C LYAPUN = 'R'. +C If JOB = 'X' or 'A', then X is an output argument and on +C exit, if INFO = 0 or INFO = N+1, the leading N-by-N part +C of this array contains the symmetric solution matrix X of +C of the original Lyapunov equation (with matrix A), if +C LYAPUN = 'O', or of the reduced Lyapunov equation (with +C matrix T), if LYAPUN = 'R'. +C If JOB = 'S', the array X is not referenced. +C +C LDX INTEGER +C The leading dimension of the array X. +C LDX >= 1, if JOB = 'S'; +C LDX >= MAX(1,N), otherwise. +C +C SEPD (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'C' or JOB = 'A', and INFO = 0 or +C INFO = N+1, SEPD contains the estimated separation of the +C matrices op(A) and op(A)', sepd(op(A),op(A)'). +C If N = 0, or X = 0, or JOB = 'X' or JOB = 'E', SEPD is not +C referenced. +C +C RCOND (output) DOUBLE PRECISION +C If JOB = 'C' or JOB = 'A', an estimate of the reciprocal +C condition number of the continuous-time Lyapunov equation. +C If N = 0 or X = 0, RCOND is set to 1 or 0, respectively. +C If JOB = 'X' or JOB = 'S' or JOB = 'E', RCOND is not +C referenced. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'E' or JOB = 'A', and INFO = 0 or INFO = N+1, +C FERR contains an estimated forward error bound for the +C solution X. If XTRUE is the true solution, FERR bounds the +C relative error in the computed solution, measured in the +C Frobenius norm: norm(X - XTRUE)/norm(XTRUE). +C If N = 0 or X = 0, FERR is set to 0. +C If JOB = 'X' or JOB = 'S' or JOB = 'C', FERR is not +C referenced. +C +C WR (output) DOUBLE PRECISION array, dimension (N) +C WI (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N', and INFO = 0 or INFO = N+1, WR and WI +C contain the real and imaginary parts, respectively, of the +C eigenvalues of A. +C If FACT = 'F', WR and WI are not referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N*N) +C This array is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or INFO = N+1, DWORK(1) returns the +C optimal value of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If JOB = 'X', then +C LDWORK >= MAX(1,N*N,2*N), if FACT = 'F'; +C LDWORK >= MAX(1,N*N,3*N), if FACT = 'N'. +C If JOB = 'S', then +C LDWORK >= MAX(3,2*N*N). +C If JOB = 'C', then +C LDWORK >= MAX(3,2*N*N) + N*N. +C If JOB = 'E', or JOB = 'A', then +C LDWORK >= MAX(3,2*N*N) + N*N + 2*N. +C For optimum performance LDWORK should sometimes be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, i <= N, the QR algorithm failed to +C complete the reduction to Schur canonical form (see +C LAPACK Library routine DGEES); on exit, the matrix +C T(i+1:N,i+1:N) contains the partially converged +C Schur form, and the elements i+1:n of WR and WI +C contain the real and imaginary parts, respectively, +C of the converged eigenvalues; this error is unlikely +C to appear; +C = N+1: if the matrix T has almost reciprocal eigenvalues; +C perturbed values were used to solve Lyapunov +C equations, but the matrix T, if given (for +C FACT = 'F'), is unchanged. +C +C METHOD +C +C After reducing matrix A to real Schur canonical form (if needed), +C a discrete-time version of the Bartels-Stewart algorithm is used. +C A set of equivalent linear algebraic systems of equations of order +C at most four are formed and solved using Gaussian elimination with +C complete pivoting. +C +C The condition number of the discrete-time Lyapunov equation is +C estimated as +C +C cond = (norm(Theta)*norm(A) + norm(inv(Omega))*norm(C))/norm(X), +C +C where Omega and Theta are linear operators defined by +C +C Omega(W) = op(A)'*W*op(A) - W, +C Theta(W) = inv(Omega(op(W)'*X*op(A) + op(A)'*X*op(W))). +C +C The routine estimates the quantities +C +C sepd(op(A),op(A)') = 1 / norm(inv(Omega)) +C +C and norm(Theta) using 1-norm condition estimators. +C +C The forward error bound is estimated using a practical error bound +C similar to the one proposed in [3]. +C +C REFERENCES +C +C [1] Barraud, A.Y. T +C A numerical algorithm to solve A XA - X = Q. +C IEEE Trans. Auto. Contr., AC-22, pp. 883-885, 1977. +C +C [2] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [3] Higham, N.J. +C Perturbation theory and backward error for AX-XB=C. +C BIT, vol. 33, pp. 124-136, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C The accuracy of the estimates obtained depends on the solution +C accuracy and on the properties of the 1-norm estimator. +C +C FURTHER COMMENTS +C +C The "separation" sepd of op(A) and op(A)' can also be defined as +C +C sepd( op(A), op(A)' ) = sigma_min( T ), +C +C where sigma_min(T) is the smallest singular value of the +C N*N-by-N*N matrix +C +C T = kprod( op(A)', op(A)' ) - I(N**2). +C +C I(N**2) is an N*N-by-N*N identity matrix, and kprod denotes the +C Kronecker product. The routine estimates sigma_min(T) by the +C reciprocal of an estimate of the 1-norm of inverse(T). The true +C reciprocal 1-norm of inverse(T) cannot differ from sigma_min(T) by +C more than a factor of N. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, February 1999. +C This is an extended and improved version of Release 3.0 routine +C SB03PD. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004. +C +C KEYWORDS +C +C Lyapunov equation, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER FACT, JOB, LYAPUN, TRANA, UPLO + INTEGER INFO, LDA, LDC, LDT, LDU, LDWORK, LDX, N + DOUBLE PRECISION FERR, RCOND, SCALE, SEPD +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ T( LDT, * ), U( LDU, * ), WI( * ), WR( * ), + $ X( LDX, * ) +C .. +C .. Local Scalars .. + LOGICAL JOBA, JOBC, JOBE, JOBS, JOBX, LOWER, NOFACT, + $ NOTRNA, UPDATE + CHARACTER CFACT, JOBL, SJOB + INTEGER LDW, NN, SDIM + DOUBLE PRECISION THNORM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DLACPY, DSCAL, MA02ED, MB01RU, SB03MX, + $ SB03SD, SB03SY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode option parameters. +C + JOBX = LSAME( JOB, 'X' ) + JOBS = LSAME( JOB, 'S' ) + JOBC = LSAME( JOB, 'C' ) + JOBE = LSAME( JOB, 'E' ) + JOBA = LSAME( JOB, 'A' ) + NOFACT = LSAME( FACT, 'N' ) + NOTRNA = LSAME( TRANA, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + UPDATE = LSAME( LYAPUN, 'O' ) +C +C Compute workspace. +C + NN = N*N + IF( JOBX ) THEN + IF( NOFACT ) THEN + LDW = MAX( 1, NN, 3*N ) + ELSE + LDW = MAX( 1, NN, 2*N ) + END IF + ELSE IF( JOBS ) THEN + LDW = MAX( 3, 2*NN ) + ELSE IF( JOBC ) THEN + LDW = MAX( 3, 2*NN ) + NN + ELSE + LDW = MAX( 3, 2*NN ) + NN + 2*N + END IF +C +C Test the scalar input parameters. +C + INFO = 0 + IF( .NOT.( JOBX .OR. JOBS .OR. JOBC .OR. JOBE .OR. JOBA ) ) THEN + INFO = -1 + ELSE IF( .NOT.( NOFACT .OR. LSAME( FACT, 'F' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR. + $ LSAME( TRANA, 'C' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( ( JOBC .OR. JOBE ) .AND. + $ ( SCALE.LT.ZERO .OR. SCALE.GT.ONE ) )THEN + INFO = -7 + ELSE IF( LDA.LT.1 .OR. + $ ( LDA.LT.N .AND. ( ( UPDATE .AND. .NOT.JOBX ) .OR. + $ NOFACT ) ) ) THEN + INFO = -9 + ELSE IF( LDT.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDU.LT.1 .OR. ( LDU.LT.N .AND. UPDATE ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.1 .OR. ( .NOT.JOBS .AND. LDC.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.1 .OR. ( .NOT.JOBS .AND. LDX.LT.N ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.LDW ) THEN + INFO = -25 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB03UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + IF( JOBX .OR. JOBA ) + $ SCALE = ONE + IF( JOBC .OR. JOBA ) + $ RCOND = ONE + IF( JOBE .OR. JOBA ) + $ FERR = ZERO + DWORK( 1 ) = ONE + RETURN + END IF +C + IF( NOFACT ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 3*N; +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, T, LDT ) + IF( UPDATE ) THEN + SJOB = 'V' + ELSE + SJOB = 'N' + END IF + CALL DGEES( SJOB, 'Not ordered', SELECT, N, T, LDT, SDIM, WR, + $ WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.GT.0 ) + $ RETURN + LDW = MAX( LDW, INT( DWORK( 1 ) ) ) + CFACT = 'F' + ELSE + CFACT = FACT + END IF +C + IF( JOBX .OR. JOBA ) THEN +C +C Copy the right-hand side in X. +C + CALL DLACPY( UPLO, N, N, C, LDC, X, LDX ) +C + IF( UPDATE ) THEN +C +C Transform the right-hand side. +C Workspace: need N*N. +C + CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, U, + $ LDU, X, LDX, DWORK, LDWORK, INFO ) + CALL DSCAL( N, HALF, X, LDX+1 ) + END IF +C +C Fill in the remaining triangle of X. +C + CALL MA02ED( UPLO, N, X, LDX ) +C +C Solve the transformed equation. +C Workspace: 2*N. +C + CALL SB03MX( TRANA, N, T, LDT, X, LDX, SCALE, DWORK, INFO ) + IF( INFO.GT.0 ) + $ INFO = N + 1 +C + IF( UPDATE ) THEN +C +C Transform back the solution. +C + CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE, X, LDX, + $ U, LDU, X, LDX, DWORK, LDWORK, INFO ) + CALL DSCAL( N, HALF, X, LDX+1 ) +C +C Fill in the remaining triangle of X. +C + CALL MA02ED( UPLO, N, X, LDX ) + END IF + END IF +C + IF( JOBS ) THEN +C +C Estimate sepd(op(A),op(A)'). +C Workspace: MAX(3,2*N*N). +C + CALL SB03SY( 'Separation', TRANA, LYAPUN, N, T, LDT, U, LDU, + $ DWORK, 1, SEPD, THNORM, IWORK, DWORK, LDWORK, + $ INFO ) +C + ELSE IF( .NOT.JOBX ) THEN +C +C Estimate the reciprocal condition and/or the error bound. +C Workspace: MAX(3,2*N*N) + N*N + a*N, where: +C a = 2, if JOB = 'E' or JOB = 'A'; +C a = 0, otherwise. +C + IF( JOBA ) THEN + JOBL = 'B' + ELSE + JOBL = JOB + END IF + CALL SB03SD( JOBL, CFACT, TRANA, UPLO, LYAPUN, N, SCALE, A, + $ LDA, T, LDT, U, LDU, C, LDC, X, LDX, SEPD, RCOND, + $ FERR, IWORK, DWORK, LDWORK, INFO ) + LDW = MAX( LDW, INT( DWORK( 1 ) ) ) + END IF +C + DWORK( 1 ) = DBLE( LDW ) +C + RETURN +C *** Last line of SB03UD *** + END diff --git a/mex/sources/libslicot/SB04MD.f b/mex/sources/libslicot/SB04MD.f new file mode 100644 index 000000000..c618c8ac7 --- /dev/null +++ b/mex/sources/libslicot/SB04MD.f @@ -0,0 +1,347 @@ + SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the continuous-time Sylvester equation +C +C AX + XB = C +C +C where A, B, C and X are general N-by-N, M-by-M, N-by-M and +C N-by-M matrices respectively. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the matrix H, and the remainder of the +C leading N-by-N part, together with the elements 2,3,...,N +C of array DWORK, contain the orthogonal transformation +C matrix U (stored in factored form). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix B of the equation. +C On exit, the leading M-by-M part of this array contains +C the quasi-triangular Schur factor S of the matrix B'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading N-by-M part of this array contains +C the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) +C The leading M-by-M part of this array contains the +C orthogonal matrix Z used to transform B' to real upper +C Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (4*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain +C the scalar factors of the elementary reflectors used to +C reduce A to upper Hessenberg form, as returned by LAPACK +C Library routine DGEHRD. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = MAX(1, 2*N*N + 8*N, 5*M, N + M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to +C compute all the eigenvalues (see LAPACK Library +C routine DGEES); +C > M: if a singular matrix was encountered whilst solving +C for the (INFO-M)-th column of matrix X. +C +C METHOD +C +C The matrix A is transformed to upper Hessenberg form H = U'AU by +C the orthogonal transformation matrix U; matrix B' is transformed +C to real upper Schur form S = Z'B'Z using the orthogonal +C transformation matrix Z. The matrix C is also multiplied by the +C transformations, F = U'CZ, and the solution matrix Y of the +C transformed system +C +C HY + YS' = F +C +C is computed by back substitution. Finally, the matrix Y is then +C multiplied by the orthogonal transformation matrices, X = UYZ', in +C order to obtain the solution matrix X to the original problem. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C 3 3 2 2 +C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N +C operations and is backward stable. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04AD by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000, Aug. 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER I, IEIG, IFAIL, IHI, ILO, IND, ITAU, JWORK, + $ SDIM, WRKOPT +C .. Local Scalars .. + LOGICAL SELECT +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, + $ DORMHR, DSWAP, SB04MU, SB04MY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 8*N, 5*M, N + M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ILO = 1 + IHI = N + WRKOPT = 1 +C +C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper +C triangular. That is, H = U' * A * U (store U in factored +C form) and S = Z' * B' * Z (save Z). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 20 I = 2, M + CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) + 20 CONTINUE +C +C Workspace: need 5*M; +C prefer larger. +C + IEIG = M + 1 + JWORK = IEIG + M + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, + $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), + $ LDWORK-JWORK+1, BWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + ITAU = 2 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN + CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, + $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) + WRKOPT = MAX( WRKOPT, JWORK - 1 + N*M ) + ELSE +C + DO 40 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 40 CONTINUE +C + END IF +C + IND = M + 60 CONTINUE + IF ( IND.GT.1 ) THEN +C +C Step 3 : Solve H * Y + Y * S' = F for Y. +C + IF ( B(IND,IND-1).EQ.ZERO ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N. +C + CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) + IND = IND - 1 + ELSE +C +C Solve a special linear algebraic system of order 2*N. +C Workspace: 2*N*N + 8*N; +C + CALL SB04MU( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + 2*N*N + 7*N - 1 ) + IND = IND - 2 + END IF + GO TO 60 + ELSE IF ( IND.EQ.1 ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N; +C + CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 ) + END IF +C +C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN + CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, + $ Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) + ELSE +C + DO 80 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 80 CONTINUE + END IF +C + RETURN +C *** Last line of SB04MD *** + END diff --git a/mex/sources/libslicot/SB04MR.f b/mex/sources/libslicot/SB04MR.f new file mode 100644 index 000000000..a8aa560cd --- /dev/null +++ b/mex/sources/libslicot/SB04MR.f @@ -0,0 +1,222 @@ + SUBROUTINE SB04MR( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix has zeros below the second subdiagonal. The matrix is +C stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0. +C Note that parameter M should have twice the value in the +C original problem (see SLICOT Library routine SB04MU). +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*(M+1)/2+3*M) +C On entry, the first M*(M+1)/2 + 2*M elements of this array +C must contain the coefficient matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04MU. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AR by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, + $ MPI2 + DOUBLE PRECISION D1, D2, D3, DMAX +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + I2 = ( M*( M + 5 ) )/2 + MPI = M + IPRM = I2 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GE.3 ) M1 = M1 - 1 + 20 CONTINUE +C + M1 = M - 1 + MPI1 = M + 1 +C +C Reduce to upper triangular form. +C + DO 80 I = 1, M1 + MPI = MPI1 + MPI1 = MPI1 + 1 + IPRM = IPR(MPI) + D1 = D(IPRM) + I1 = 2 + IF ( I.EQ.M1 ) I1 = 1 + MPI2 = MPI + I1 + L = 0 + DMAX = ABS( D1 ) +C + DO 40 J = MPI1, MPI2 + D2 = D(IPR(J)) + D3 = ABS( D2 ) + IF ( D3.GT.DMAX ) THEN + DMAX = D3 + D1 = D2 + L = J - MPI + END IF + 40 CONTINUE +C +C Check singularity. +C + IF ( DMAX.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + IF ( L.GT.0 ) THEN +C +C Permute the row indices. +C + K = IPRM + J = MPI + L + IPRM = IPR(J) + IPR(J) = K + IPR(MPI) = IPRM + K = IPR(I) + I2 = I + L + IPR(I) = IPR(I2) + IPR(I2) = K + END IF + IPRM = IPRM + 1 +C +C Annihilate the subdiagonal elements of the matrix. +C + I2 = I + D3 = D(IPR(I)) +C + DO 60 J = MPI1, MPI2 + I2 = I2 + 1 + IPRM1 = IPR(J) + DMAX = -D(IPRM1)/D1 + D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 + CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) + 60 CONTINUE +C + IPR(MPI1) = IPR(MPI1) + 1 + IF ( I.NE.M1 ) IPR(MPI2) = IPR(MPI2) + 1 + 80 CONTINUE +C + MPI = M + M + IPRM = IPR(MPI) +C +C Check singularity. +C + IF ( D(IPRM).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPRM) +C + DO 120 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + DMAX = ZERO +C + DO 100 K = I+1, M + IPRM1 = IPRM1 + 1 + DMAX = DMAX + D(IPR(K))*D(IPRM1) + 100 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) + 120 CONTINUE +C + RETURN +C *** Last line of SB04MR *** + END diff --git a/mex/sources/libslicot/SB04MU.f b/mex/sources/libslicot/SB04MU.f new file mode 100644 index 000000000..ed3879eca --- /dev/null +++ b/mex/sources/libslicot/SB04MU.f @@ -0,0 +1,190 @@ + SUBROUTINE SB04MU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order 2*M +C whose coefficient matrix has zeros below the second subdiagonal. +C Such systems appear when solving continuous-time Sylvester +C equations using the Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C IND and IND - 1 specify the indices of the columns in C +C to be computed. IND > 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with columns IND-1 and IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (2*M*M+7*M) +C +C IPR INTEGER array, dimension (4*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order 2*M, whose coefficient +C matrix has zeros below the second subdiagonal is constructed and +C solved. The coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AU by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, IND1, J, K, K1, K2, M2 + DOUBLE PRECISION TEMP +C .. External Subroutines .. + EXTERNAL DAXPY, SB04MR +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + IND1 = IND - 1 +C + DO 20 I = IND + 1, N + CALL DAXPY( M, -B(IND1,I), C(1,I), 1, C(1,IND1), 1 ) + CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) + 20 CONTINUE +C +C Construct the linear algebraic system of order 2*M. +C + K1 = -1 + M2 = 2*M + I2 = M*(M2 + 5) + K = M2 +C + DO 60 I = 1, M +C + DO 40 J = MAX( 1, I - 1 ), M + K1 = K1 + 2 + K2 = K1 + K + TEMP = A(I,J) + IF ( I.NE.J ) THEN + D(K1) = TEMP + D(K1+1) = ZERO + IF ( J.GT.I ) D(K2) = ZERO + D(K2+1) = TEMP + ELSE + D(K1) = TEMP + B(IND1,IND1) + D(K1+1) = B(IND1,IND) + D(K2) = B(IND,IND1) + D(K2+1) = TEMP + B(IND,IND) + END IF + 40 CONTINUE +C + K1 = K2 + K = K - MIN( 2, I ) +C +C Store the right hand side. +C + I2 = I2 + 2 + D(I2) = C(I,IND) + D(I2-1) = C(I,IND1) + 60 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MR( M2, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE + I2 = 0 +C + DO 80 I = 1, M + I2 = I2 + 2 + C(I,IND1) = D(IPR(I2-1)) + C(I,IND) = D(IPR(I2)) + 80 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04MU *** + END diff --git a/mex/sources/libslicot/SB04MW.f b/mex/sources/libslicot/SB04MW.f new file mode 100644 index 000000000..9a56f4658 --- /dev/null +++ b/mex/sources/libslicot/SB04MW.f @@ -0,0 +1,194 @@ + SUBROUTINE SB04MW( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix is in upper Hessenberg form, stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*(M+1)/2+2*M) +C On entry, the first M*(M+1)/2 + M elements of this array +C must contain an upper Hessenberg matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04MY. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AW by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, IPRM, IPRM1, K, M1, M2, MPI + DOUBLE PRECISION D1, D2, MULT +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 + M1 = ( M*( M + 3 ) )/2 + M2 = M + M + MPI = M + IPRM = M1 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GT.1 ) M1 = M1 - 1 + 20 CONTINUE +C + M1 = M - 1 + MPI = M +C +C Reduce to upper triangular form. +C + DO 40 I = 1, M1 + I1 = I + 1 + MPI = MPI + 1 + IPRM = IPR(MPI) + IPRM1 = IPR(MPI+1) + D1 = D(IPRM) + D2 = D(IPRM1) + IF ( ABS( D1 ).LE.ABS( D2 ) ) THEN +C +C Permute the row indices. +C + K = IPRM + IPR(MPI) = IPRM1 + IPRM = IPRM1 + IPRM1 = K + K = IPR(I) + IPR(I) = IPR(I1) + IPR(I1) = K + D1 = D2 + END IF +C +C Check singularity. +C + IF ( D1.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + MULT = -D(IPRM1)/D1 + IPRM1 = IPRM1 + 1 + IPR(MPI+1) = IPRM1 +C +C Annihilate the subdiagonal elements of the matrix. +C + D(IPR(I1)) = D(IPR(I1)) + MULT*D(IPR(I)) + CALL DAXPY( M-I, MULT, D(IPRM+1), 1, D(IPRM1), 1 ) + 40 CONTINUE +C +C Check singularity. +C + IF ( D(IPR(M2)).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPR(M2)) + MPI = M2 +C + DO 80 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + MULT = ZERO +C + DO 60 I1 = I + 1, M + IPRM1 = IPRM1 + 1 + MULT = MULT + D(IPR(I1))*D(IPRM1) + 60 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - MULT )/D(IPRM) + 80 CONTINUE +C + RETURN +C *** Last line of SB04MW *** + END diff --git a/mex/sources/libslicot/SB04MY.f b/mex/sources/libslicot/SB04MY.f new file mode 100644 index 000000000..d8e568e7d --- /dev/null +++ b/mex/sources/libslicot/SB04MY.f @@ -0,0 +1,168 @@ + SUBROUTINE SB04MY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order M whose +C coefficient matrix is in upper Hessenberg form. Such systems +C appear when solving Sylvester equations using the Hessenberg-Schur +C method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C The index of the column in C to be computed. IND >= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with column IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) +C +C IPR INTEGER array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order M, with coefficient +C matrix in upper Hessenberg form is constructed and solved. The +C coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB04AY by G. Golub, S. Nash, and +C C. Van Loan, Stanford University, California, United States of +C America, January 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, J, K, K1, K2, M1 +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, SB04MW +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + DO 20 I = IND + 1, N + CALL DAXPY( M, -B(IND,I), C(1,I), 1, C(1,IND), 1 ) + 20 CONTINUE +C + M1 = M + 1 + I2 = ( M*M1 )/2 + M1 + K2 = 1 + K = M +C +C Construct the linear algebraic system of order M. +C + DO 40 I = 1, M + J = M1 - K + CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) + K1 = K2 + K2 = K2 + K + IF ( I.GT.1 ) THEN + K1 = K1 + 1 + K = K - 1 + END IF + D(K1) = D(K1) + B(IND,IND) +C +C Store the right hand side. +C + D(I2) = C(I,IND) + I2 = I2 + 1 + 40 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MW( M, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE +C + DO 60 I = 1, M + C(I,IND) = D(IPR(I)) + 60 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04MY *** + END diff --git a/mex/sources/libslicot/SB04ND.f b/mex/sources/libslicot/SB04ND.f new file mode 100644 index 000000000..b567088ac --- /dev/null +++ b/mex/sources/libslicot/SB04ND.f @@ -0,0 +1,405 @@ + SUBROUTINE SB04ND( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, + $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the continuous-time Sylvester equation +C +C AX + XB = C, +C +C with at least one of the matrices A or B in Schur form and the +C other in Hessenberg or Schur form (both either upper or lower); +C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, +C respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHU CHARACTER*1 +C Indicates whether A and/or B is/are in Schur or +C Hessenberg form as follows: +C = 'A': A is in Schur form, B is in Hessenberg form; +C = 'B': B is in Schur form, A is in Hessenberg form; +C = 'S': Both A and B are in Schur form. +C +C ULA CHARACTER*1 +C Indicates whether A is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and +C upper Schur form otherwise; +C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and +C lower Schur form otherwise. +C +C ULB CHARACTER*1 +C Indicates whether B is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and +C upper Schur form otherwise; +C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and +C lower Schur form otherwise. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading M-by-M part of this array must contain the +C coefficient matrix B of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity in +C the Sylvester equation. If the user sets TOL > 0, then the +C given value of TOL is used as a lower bound for the +C reciprocal condition number; a matrix whose estimated +C condition number is less than 1/TOL is considered to be +C nonsingular. If the user sets TOL <= 0, then a default +C tolerance, defined by TOLDEF = EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*MAX(M,N)) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = 0, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; +C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if a (numerically) singular matrix T was encountered +C during the computation of the solution matrix X. +C That is, the estimated reciprocal condition number +C of T is less than or equal to TOL. +C +C METHOD +C +C Matrices A and B are assumed to be in (upper or lower) Hessenberg +C or Schur form (with at least one of them in Schur form). The +C solution matrix X is then computed by rows or columns via the back +C substitution scheme proposed by Golub, Nash and Van Loan (see +C [1]), which involves the solution of triangular systems of +C equations that are constructed recursively and which may be nearly +C singular if A and -B have close eigenvalues. If near singularity +C is detected, then the routine returns with the Error Indicator +C (INFO) set to 1. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires approximately 5M N + 0.5MN operations in +C 2 2 +C the worst case and 2.5M N + 0.5MN operations in the best case +C (where M is the order of the matrix in Hessenberg form and N is +C the order of the matrix in Schur form) and is mixed stable (see +C [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHU, ULA, ULB + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) +C .. Local Scalars .. + CHARACTER ABSCHR + LOGICAL LABSCB, LABSCS, LULA, LULB + INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, + $ LDW, MAXMN + DOUBLE PRECISION SCALE, TOL1 +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DTRSYL, SB04NV, SB04NW, SB04NX, SB04NY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + MAXMN = MAX( M, N ) + LABSCB = LSAME( ABSCHU, 'B' ) + LABSCS = LSAME( ABSCHU, 'S' ) + LULA = LSAME( ULA, 'U' ) + LULB = LSAME( ULB, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. + $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.0 .OR. ( .NOT.( LABSCS .AND. LULA .AND. LULB ) + $ .AND. LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAXMN.EQ.0 ) + $ RETURN +C + IF ( LABSCS .AND. LULA .AND. LULB ) THEN +C +C If both matrices are in a real Schur form, use DTRSYL. +C + CALL DTRSYL( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, B, + $ LDB, C, LDC, SCALE, INFO ) + IF ( SCALE.NE.ONE ) + $ INFO = 1 + RETURN + END IF +C + LDW = 2*MAXMN + JWORK = LDW*LDW + 3*LDW + 1 + TOL1 = TOL + IF ( TOL1.LE.ZERO ) + $ TOL1 = DLAMCH( 'Epsilon' ) +C +C Choose the smallest of both matrices as the one in Hessenberg +C form when possible. +C + ABSCHR = ABSCHU + IF ( LABSCS ) THEN + IF ( N.GT.M ) THEN + ABSCHR = 'A' + ELSE + ABSCHR = 'B' + END IF + END IF + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C B is in Schur form: recursion on the columns of B. +C + IF ( LULB ) THEN +C +C B is upper: forward recursion. +C + IBEG = 1 + IEND = M + FWD = 1 + INCR = 0 + ELSE +C +C B is lower: backward recursion. +C + IBEG = M + IEND = 1 + FWD = -1 + INCR = -1 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( B(I+FWD,I).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04NW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, + $ DWORK(JWORK) ) + CALL SB04NY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) + ELSE + IPINCR = I + INCR + CALL SB04NV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, + $ DWORK(JWORK) ) + CALL SB04NX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), + $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), + $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) + CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) + END IF + I = I + FWD*ISTEP + GO TO 20 + END IF +C END WHILE 20 + ELSE +C +C A is in Schur form: recursion on the rows of A. +C + IF ( LULA ) THEN +C +C A is upper: backward recursion. +C + IBEG = N + IEND = 1 + FWD = -1 + INCR = -1 + ELSE +C +C A is lower: forward recursion. +C + IBEG = 1 + IEND = N + FWD = 1 + INCR = 0 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( A(I,I+FWD).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04NW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, + $ DWORK(JWORK) ) + CALL SB04NY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + ELSE + IPINCR = I + INCR + CALL SB04NV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, + $ DWORK(JWORK) ) + CALL SB04NX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), + $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), + $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) + CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) + END IF + I = I + FWD*ISTEP + GO TO 40 + END IF +C END WHILE 40 + END IF +C + RETURN +C *** Last line of SB04ND *** + END diff --git a/mex/sources/libslicot/SB04NV.f b/mex/sources/libslicot/SB04NV.f new file mode 100644 index 000000000..bb09f2778 --- /dev/null +++ b/mex/sources/libslicot/SB04NV.f @@ -0,0 +1,165 @@ + SUBROUTINE SB04NV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the right-hand sides D for a system of equations in +C Hessenberg form solved via SB04NX (case with 2 right-hand sides). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation AX + XB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the first column/row of C to be used in +C the construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C AX + XB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading 2*N or 2*M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side stored as a matrix with two rows. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BV by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the 2 columns of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) + CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, + $ ONE, D(1), 2 ) + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX+1), + $ 1, ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.LT.M-1 ) THEN + CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX), 1, ONE, D(1), 2 ) + CALL DGEMV( 'N', N, M-INDX-1, -ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX+1), 1, ONE, D(2), 2 ) + END IF + END IF + ELSE +C +C Construct the 2 rows of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) + CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N-1 ) THEN + CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, + $ AB(INDX,INDX+2), LDAB, ONE, D(1), 2 ) + CALL DGEMV( 'T', N-INDX-1, M, -ONE, C(INDX+2,1), LDC, + $ AB(INDX+1,INDX+2), LDAB, ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), + $ LDAB, ONE, D(1), 2 ) + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX+1,1), + $ LDAB, ONE, D(2), 2 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04NV *** + END diff --git a/mex/sources/libslicot/SB04NW.f b/mex/sources/libslicot/SB04NW.f new file mode 100644 index 000000000..a2a52aa82 --- /dev/null +++ b/mex/sources/libslicot/SB04NW.f @@ -0,0 +1,155 @@ + SUBROUTINE SB04NW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, D ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the right-hand side D for a system of equations in +C Hessenberg form solved via SB04NY (case with 1 right-hand side). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation AX + XB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the column/row of C to be used in the +C construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C AX + XB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading N or M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BW by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), C(LDC,*), D(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the column of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, -ONE, C, LDC, AB(1,INDX), 1, + $ ONE, D, 1 ) + END IF + ELSE + IF ( INDX.LT.M ) THEN + CALL DGEMV( 'N', N, M-INDX, -ONE, C(1,INDX+1), LDC, + $ AB(INDX+1,INDX), 1, ONE, D, 1 ) + END IF + END IF + ELSE +C +C Construct the row of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N ) THEN + CALL DGEMV( 'T', N-INDX, M, -ONE, C(INDX+1,1), LDC, + $ AB(INDX,INDX+1), LDAB, ONE, D, 1 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, -ONE, C, LDC, AB(INDX,1), + $ LDAB, ONE, D, 1 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04NW *** + END diff --git a/mex/sources/libslicot/SB04NX.f b/mex/sources/libslicot/SB04NX.f new file mode 100644 index 000000000..ac9ecf524 --- /dev/null +++ b/mex/sources/libslicot/SB04NX.f @@ -0,0 +1,320 @@ + SUBROUTINE SB04NX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, + $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with two +C consecutive offdiagonals and two right-hand sides. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBD1, (input) DOUBLE PRECISION +C LAMBD2, These variables must contain the 2-by-2 block to be added +C LAMBD3, to the diagonal blocks of A. +C LAMBD4 +C +C D (input/output) DOUBLE PRECISION array, dimension (2*M) +C On entry, this array must contain the two right-hand +C side vectors of the Hessenberg system, stored row-wise. +C On exit, if INFO = 0, this array contains the two solution +C vectors of the Hessenberg system, stored row-wise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) +C The leading 2*M-by-2*M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 6*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. +C LDDWOR >= MAX(1,2*M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BX by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M and LDA must be such that the value of the +C LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, 2*M ) ) +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, J2, M2, MJ, ML + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DLASET, DROT, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + M2 = M*2 + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + J2 = J*2 + ML = MIN( M, J + 1 ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 + DWORK(J2,J2-1) = LAMBD3 + DWORK(J2-1,J2) = LAMBD2 + DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J+2,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) + DWORK(J+1,J) = R + DWORK(J+2,J) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, + $ DWORK(J+2,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, + $ S, R ) + DWORK(MJ+1,MJ) = R + DWORK(MJ+1,MJ-1) = ZERO + CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, + $ S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J2 = J*2 + J1 = MAX( J - 1, 1 ) + ML = MIN( M - J + 2, M ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + LAMBD1 + DWORK(J2,J2-1) = LAMBD3 + DWORK(J2-1,J2) = LAMBD2 + DWORK(J2,J2) = DWORK(J2,J2) + LAMBD4 + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, + $ S, R ) + DWORK(MJ,MJ+1) = R + DWORK(MJ-1,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M2 - 1 + MJ = M2 - J + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J,J+2).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) + DWORK(J,J+1) = R + DWORK(J,J+2) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), + $ 1, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, + $ DWORK(1,M2+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04NX *** + END diff --git a/mex/sources/libslicot/SB04NY.f b/mex/sources/libslicot/SB04NY.f new file mode 100644 index 000000000..5a0b9c62b --- /dev/null +++ b/mex/sources/libslicot/SB04NY.f @@ -0,0 +1,260 @@ + SUBROUTINE SB04NY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, + $ DWORK, LDDWOR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with one +C offdiagonal and one right-hand side. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBDA (input) DOUBLE PRECISION +C This variable must contain the value to be added to the +C diagonal elements of A. +C +C D (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the right-hand side +C vector of the Hessenberg system. +C On exit, if INFO = 0, this array contains the solution +C vector of the Hessenberg system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) +C The leading M-by-M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 3*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04BY by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M and LDA must be such that the value of the +C LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, M ) ) +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBDA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, MJ + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DROT, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + LAMBDA + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J1 = MAX( J - 1, 1 ) + CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + LAMBDA + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) +C + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, + $ DWORK(1,M+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04NY *** + END diff --git a/mex/sources/libslicot/SB04OD.f b/mex/sources/libslicot/SB04OD.f new file mode 100644 index 000000000..6a11ffa76 --- /dev/null +++ b/mex/sources/libslicot/SB04OD.f @@ -0,0 +1,1028 @@ + SUBROUTINE SB04OD( REDUCE, TRANS, JOBD, M, N, A, LDA, B, LDB, C, + $ LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, P, + $ LDP, Q, LDQ, U, LDU, V, LDV, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for R and L one of the generalized Sylvester equations +C +C A * R - L * B = scale * C ) +C ) (1) +C D * R - L * E = scale * F ) +C +C or +C +C A' * R + D' * L = scale * C ) +C ) (2) +C R * B' + L * E' = scale * (-F) ) +C +C where A and D are M-by-M matrices, B and E are N-by-N matrices and +C C, F, R and L are M-by-N matrices. +C +C The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an +C output scaling factor chosen to avoid overflow. +C +C The routine also optionally computes a Dif estimate, which +C measures the separation of the spectrum of the matrix pair (A,D) +C from the spectrum of the matrix pair (B,E), Dif[(A,D),(B,E)]. +C +C ARGUMENTS +C +C MODE PARAMETERS +C +C REDUCE CHARACTER*1 +C Indicates whether the matrix pairs (A,D) and/or (B,E) are +C to be reduced to generalized Schur form as follows: +C = 'R': The matrix pairs (A,D) and (B,E) are to be reduced +C to generalized (real) Schur canonical form; +C = 'A': The matrix pair (A,D) only is to be reduced +C to generalized (real) Schur canonical form, +C and the matrix pair (B,E) already is in this form; +C = 'B': The matrix pair (B,E) only is to be reduced +C to generalized (real) Schur canonical form, +C and the matrix pair (A,D) already is in this form; +C = 'N': The matrix pairs (A,D) and (B,E) are already in +C generalized (real) Schur canonical form, as +C produced by LAPACK routine DGEES. +C +C TRANS CHARACTER*1 +C Indicates which of the equations, (1) or (2), is to be +C solved as follows: +C = 'N': The generalized Sylvester equation (1) is to be +C solved; +C = 'T': The "transposed" generalized Sylvester equation +C (2) is to be solved. +C +C JOBD CHARACTER*1 +C Indicates whether the Dif estimator is to be computed as +C follows: +C = '1': Only the one-norm-based Dif estimate is computed +C and stored in DIF; +C = '2': Only the Frobenius norm-based Dif estimate is +C computed and stored in DIF; +C = 'D': The equation (1) is solved and the one-norm-based +C Dif estimate is computed and stored in DIF; +C = 'F': The equation (1) is solved and the Frobenius norm- +C based Dif estimate is computed and stored in DIF; +C = 'N': The Dif estimator is not required and hence DIF is +C not referenced. (Solve either (1) or (2) only.) +C JOBD is not referenced if TRANS = 'T'. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrices A and D and the number of rows +C of the matrices C, F, R and L. M >= 0. +C +C N (input) INTEGER +C The order of the matrices B and E and the number of +C columns of the matrices C, F, R and L. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix A of the equation; A must +C be in upper quasi-triangular form if REDUCE = 'B' or 'N'. +C On exit, the leading M-by-M part of this array contains +C the upper quasi-triangular form of A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix B of the equation; B must +C be in upper quasi-triangular form if REDUCE = 'A' or 'N'. +C On exit, the leading N-by-N part of this array contains +C the upper quasi-triangular form of B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand side matrix C of the first equation +C in (1) or (2). +C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N +C part of this array contains the solution matrix R of the +C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading +C M-by-N part of this array contains the solution matrix R +C achieved during the computation of the Dif estimate. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix D of the equation; D must +C be in upper triangular form if REDUCE = 'B' or 'N'. +C On exit, the leading M-by-M part of this array contains +C the upper triangular form of D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix E of the equation; E must +C be in upper triangular form if REDUCE = 'A' or 'N'. +C On exit, the leading N-by-N part of this array contains +C the upper triangular form of E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand side matrix F of the second +C equation in (1) or (2). +C On exit, if JOBD = 'N', 'D' or 'F', the leading M-by-N +C part of this array contains the solution matrix L of the +C problem; if JOBD = '1' or '2' and TRANS = 'N', the leading +C M-by-N part of this array contains the solution matrix L +C achieved during the computation of the Dif estimate. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scaling factor in (1) or (2). If 0 < SCALE < 1, C and +C F hold the solutions R and L, respectively, to a slightly +C perturbed system (but the input or computed generalized +C (real) Schur canonical form matrices A, B, D, and E +C have not been changed). If SCALE = 0, C and F hold the +C solutions R and L, respectively, to the homogeneous system +C with C = F = 0. Normally, SCALE = 1. +C +C DIF (output) DOUBLE PRECISION +C If TRANS = 'N' and JOBD <> 'N', then DIF contains the +C value of the Dif estimator, which is an upper bound of +C -1 +C Dif[(A,D),(B,E)] = sigma_min(Z) = 1/||Z ||, in either the +C one-norm, or Frobenius norm, respectively (see METHOD). +C Otherwise, DIF is not referenced. +C +C P (output) DOUBLE PRECISION array, dimension (LDP,*) +C If REDUCE = 'R' or 'A', then the leading M-by-M part of +C this array contains the (left) transformation matrix used +C to reduce (A,D) to generalized Schur form. +C Otherwise, P is not referenced and can be supplied as a +C dummy array (i.e. set parameter LDP = 1 and declare this +C array to be P(1,1) in the calling program). +C +C LDP INTEGER +C The leading dimension of array P. +C LDP >= MAX(1,M) if REDUCE = 'R' or 'A', +C LDP >= 1 if REDUCE = 'B' or 'N'. +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,*) +C If REDUCE = 'R' or 'A', then the leading M-by-M part of +C this array contains the (right) transformation matrix used +C to reduce (A,D) to generalized Schur form. +C Otherwise, Q is not referenced and can be supplied as a +C dummy array (i.e. set parameter LDQ = 1 and declare this +C array to be Q(1,1) in the calling program). +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,M) if REDUCE = 'R' or 'A', +C LDQ >= 1 if REDUCE = 'B' or 'N'. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,*) +C If REDUCE = 'R' or 'B', then the leading N-by-N part of +C this array contains the (left) transformation matrix used +C to reduce (B,E) to generalized Schur form. +C Otherwise, U is not referenced and can be supplied as a +C dummy array (i.e. set parameter LDU = 1 and declare this +C array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= MAX(1,N) if REDUCE = 'R' or 'B', +C LDU >= 1 if REDUCE = 'A' or 'N'. +C +C V (output) DOUBLE PRECISION array, dimension (LDV,*) +C If REDUCE = 'R' or 'B', then the leading N-by-N part of +C this array contains the (right) transformation matrix used +C to reduce (B,E) to generalized Schur form. +C Otherwise, V is not referenced and can be supplied as a +C dummy array (i.e. set parameter LDV = 1 and declare this +C array to be V(1,1) in the calling program). +C +C LDV INTEGER +C The leading dimension of array V. +C LDV >= MAX(1,N) if REDUCE = 'R' or 'B', +C LDV >= 1 if REDUCE = 'A' or 'N'. +C +C Workspace +C +C IWORK INTEGER array, dimension (M+N+6) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C If TRANS = 'N' and JOBD = 'D' or 'F', then +C LDWORK = MAX(1,7*M,7*N,2*M*N) if REDUCE = 'R'; +C LDWORK = MAX(1,7*M,2*M*N) if REDUCE = 'A'; +C LDWORK = MAX(1,7*N,2*M*N) if REDUCE = 'B'; +C LDWORK = MAX(1,2*M*N) if REDUCE = 'N'. +C Otherwise, the term 2*M*N above should be omitted. +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 REDUCE <> 'N' and either (A,D) and/or (B,E) +C cannot be reduced to generalized Schur form; +C = 2: if REDUCE = 'N' and either A or B is not in +C upper quasi-triangular form; +C = 3: if a singular matrix was encountered during the +C computation of the solution matrices R and L, that +C is (A,D) and (B,E) have common or close eigenvalues. +C +C METHOD +C +C For the case TRANS = 'N', and REDUCE = 'R' or 'N', the algorithm +C used by the routine consists of four steps (see [1] and [2]) as +C follows: +C +C (a) if REDUCE = 'R', then the matrix pairs (A,D) and (B,E) are +C transformed to generalized Schur form, i.e. orthogonal +C matrices P, Q, U and V are computed such that P' * A * Q +C and U' * B * V are in upper quasi-triangular form and +C P' * D * Q and U' * E * V are in upper triangular form; +C (b) if REDUCE = 'R', then the matrices C and F are transformed +C to give P' * C * V and P' * F * V respectively; +C (c) if REDUCE = 'R', then the transformed system +C +C P' * A * Q * R1 - L1 * U' * B * V = scale * P' * C * V +C P' * D * Q * R1 - L1 * U' * E * V = scale * P' * F * V +C +C is solved to give R1 and L1; otherwise, equation (1) is +C solved to give R and L directly. The Dif estimator +C is also computed if JOBD <> 'N'. +C (d) if REDUCE = 'R', then the solution is transformed back +C to give R = Q * R1 * V' and L = P * L1 * U'. +C +C By using Kronecker products, equation (1) can also be written as +C the system of linear equations Z * x = scale*y (see [1]), where +C +C | I*A I*D | +C Z = | |. +C |-B'*I -E'*I | +C +C -1 +C If JOBD <> 'N', then a lower bound on ||Z ||, in either the one- +C norm or Frobenius norm, is computed, which in most cases is +C a reliable estimate of the true value. Notice that since Z is a +C matrix of order 2 * M * N, the exact value of Dif (i.e., in the +C Frobenius norm case, the smallest singular value of Z) may be very +C expensive to compute. +C +C The case TRANS = 'N', and REDUCE = 'A' or 'B', is similar, but +C only one of the matrix pairs should be reduced and the +C calculations simplify. +C +C For the case TRANS = 'T', and REDUCE = 'R' or 'N', the algorithm +C is similar, but the steps (b), (c), and (d) are as follows: +C +C (b) if REDUCE = 'R', then the matrices C and F are transformed +C to give Q' * C * V and P' * F * U respectively; +C (c) if REDUCE = 'R', then the transformed system +C +C Q' * A' * P * R1 + Q' * D' * P * L1 = scale * Q' * C * V +C R1 * V' * B' * U + L1 * V' * E' * U = -scale * P' * F * U +C +C is solved to give R1 and L1; otherwise, equation (2) is +C solved to give R and L directly. +C (d) if REDUCE = 'R', then the solution is transformed back +C to give R = P * R1 * V' and L = P * L1 * V'. +C +C REFERENCES +C +C [1] Kagstrom, B. and Westin, L. +C Generalized Schur Methods with Condition Estimators for +C Solving the Generalized Sylvester Equation. +C IEEE Trans. Auto. Contr., 34, pp. 745-751, 1989. +C [2] Kagstrom, B. and Westin, L. +C GSYLV - Fortran Routines for the Generalized Schur Method with +C Dif Estimators for Solving the Generalized Sylvester +C Equation. +C Report UMINF-132.86, Institute of Information Processing, +C Univ. of Umea, Sweden, July 1987. +C [3] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur Method for the Problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C [4] Kagstrom, B. and Van Dooren, P. +C Additive Decomposition of a Transfer Function with respect to +C a Specified Region. +C In: "Signal Processing, Scattering and Operator Theory, and +C Numerical Methods" (Eds. M.A. Kaashoek et al.). +C Proceedings of MTNS-89, Vol. 3, pp. 469-477, Birkhauser Boston +C Inc., 1990. +C [5] Kagstrom, B. and Van Dooren, P. +C A Generalized State-space Approach for the Additive +C Decomposition of a Transfer Matrix. +C Report UMINF-91.12, Institute of Information Processing, Univ. +C of Umea, Sweden, April 1991. +C +C NUMERICAL ASPECTS +C +C The algorithm is backward stable. A reliable estimate for the +C condition number of Z in the Frobenius norm, is (see [1]) +C +C K(Z) = SQRT( ||A||**2 + ||B||**2 + ||C||**2 + ||D||**2 )/DIF. +C +C If mu is an upper bound on the relative error of the elements of +C the matrices A, B, C, D, E and F, then the relative error in the +C actual solution is approximately mu * K(Z). +C +C The relative error in the computed solution (due to rounding +C errors) is approximately EPS * K(Z), where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C +C FURTHER COMMENTS +C +C For applications of the generalized Sylvester equation in control +C theory, see [4] and [5]. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB04CD by Bo Kagstrom and Lars +C Westin. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Dec. 1999, +C May 2009. +C +C KEYWORDS +C +C Generalized eigenvalue problem, orthogonal transformation, real +C Schur form, Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBD, REDUCE, TRANS + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, LDP, LDQ, + $ LDU, LDV, LDWORK, M, N + DOUBLE PRECISION DIF, SCALE +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), E(LDE,*), F(LDF,*), P(LDP,*), + $ Q(LDQ,*), U(LDU,*), V(LDV,*) +C .. Local Scalars .. + LOGICAL ILASCL, ILBSCL, ILDSCL, ILESCL, LJOB1, LJOB2, + $ LJOBD, LJOBDF, LJOBF, LREDRA, LREDRB, LREDUA, + $ LREDUB, LREDUC, LREDUR, LTRANN, SUFWRK + INTEGER I, IERR, IJOB, MINWRK, MN, WRKOPT + DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, DNRM, + $ DNRMTO, ENRM, ENRMTO, SAFMAX, SAFMIN, SMLNUM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEGS, DGEMM, DGEMV, DLABAD, DLACPY, + $ DLASCL, DTGSYL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, SQRT +C .. Executable Statements .. +C + INFO = 0 + MN = MAX( M, N ) + LREDUR = LSAME( REDUCE, 'R' ) + LREDUA = LSAME( REDUCE, 'A' ) + LREDUB = LSAME( REDUCE, 'B' ) + LREDRA = LREDUR.OR.LREDUA + LREDRB = LREDUR.OR.LREDUB + LREDUC = LREDRA.OR.LREDUB + IF ( LREDUR ) THEN + MINWRK = MAX( 1, 7*MN ) + ELSE IF ( LREDUA ) THEN + MINWRK = MAX( 1, 7*M ) + ELSE IF ( LREDUB ) THEN + MINWRK = MAX( 1, 7*N ) + ELSE + MINWRK = 1 + END IF + LTRANN = LSAME( TRANS, 'N' ) + IF ( LTRANN ) THEN + LJOB1 = LSAME( JOBD, '1' ) + LJOB2 = LSAME( JOBD, '2' ) + LJOBD = LSAME( JOBD, 'D' ) + LJOBF = LSAME( JOBD, 'F' ) + LJOBDF = LJOB1.OR.LJOB2.OR.LJOBD.OR.LJOBF + IF ( LJOBD.OR.LJOBF ) MINWRK = MAX( MINWRK, 2*M*N ) + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.LREDUC .AND. .NOT.LSAME( REDUCE, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LTRANN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( LTRANN ) THEN + IF( .NOT.LJOBDF .AND. .NOT.LSAME( JOBD, 'N' ) ) + $ INFO = -3 + END IF + IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -17 + ELSE IF( ( .NOT.LREDRA .AND. LDP.LT.1 ) .OR. + $ ( LREDRA .AND. LDP.LT.MAX( 1, M ) ) ) THEN + INFO = -21 + ELSE IF( ( .NOT.LREDRA .AND. LDQ.LT.1 ) .OR. + $ ( LREDRA .AND. LDQ.LT.MAX( 1, M ) ) ) THEN + INFO = -23 + ELSE IF( ( .NOT.LREDRB .AND. LDU.LT.1 ) .OR. + $ ( LREDRB .AND. LDU.LT.MAX( 1, N ) ) ) THEN + INFO = -25 + ELSE IF( ( .NOT.LREDRB .AND. LDV.LT.1 ) .OR. + $ ( LREDRB .AND. LDV.LT.MAX( 1, N ) ) ) THEN + INFO = -27 + ELSE IF( LDWORK.LT.MINWRK ) THEN + INFO = -30 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + SCALE = ONE + DWORK(1) = ONE + IF ( LTRANN ) THEN + IF ( LJOBDF ) DIF = ONE + END IF + RETURN + END IF + WRKOPT = 1 + SUFWRK = LDWORK.GE.M*N +C +C STEP 1: Reduce (A,D) and/or (B,E) to generalized Schur form. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + IF ( LREDUC ) THEN +C +C Get machine constants. +C + SAFMIN = DLAMCH( 'Safe minimum' ) + SAFMAX = ONE / SAFMIN + CALL DLABAD( SAFMIN, SAFMAX ) + SMLNUM = SQRT( SAFMIN ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM +C + IF ( .NOT.LREDUB ) THEN +C +C Scale A if max element outside range [SMLNUM,BIGNUM]. +C + ANRM = DLANGE( 'M', M, M, A, LDA, DWORK ) + ILASCL = .FALSE. + IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN + ANRMTO = SMLNUM + ILASCL = .TRUE. + ELSE IF( ANRM.GT.BIGNUM ) THEN + ANRMTO = BIGNUM + ILASCL = .TRUE. + END IF + IF( ILASCL ) + $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, M, M, A, LDA, + $ IERR ) +C +C Scale D if max element outside range [SMLNUM,BIGNUM] +C + DNRM = DLANGE( 'M', M, M, D, LDD, DWORK ) + ILDSCL = .FALSE. + IF( DNRM.GT.ZERO .AND. DNRM.LT.SMLNUM ) THEN + DNRMTO = SMLNUM + ILDSCL = .TRUE. + ELSE IF( DNRM.GT.BIGNUM ) THEN + DNRMTO = BIGNUM + ILDSCL = .TRUE. + END IF + IF( ILDSCL ) + $ CALL DLASCL( 'G', 0, 0, DNRM, DNRMTO, M, M, D, LDD, + $ IERR ) +C +C Reduce (A,D) to generalized Schur form. +C Workspace: need 7*M; +C prefer 5*M + M*(NB+1). +C + CALL DGEGS( 'Vectors left', 'Vectors right', M, A, LDA, D, + $ LDD, DWORK, DWORK(M+1), DWORK(2*M+1), P, LDP, Q, + $ LDQ, DWORK(3*M+1), LDWORK-3*M, INFO ) +C +C Undo scaling +C + IF( ILASCL ) + $ CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, M, M, A, LDA, + $ IERR ) +C + IF( ILDSCL ) + $ CALL DLASCL( 'U', 0, 0, DNRMTO, DNRM, M, M, D, LDD, + $ IERR ) +C + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(3*M+1) ) + 3*M ) + END IF + IF ( .NOT.LREDUA ) THEN +C +C Scale B if max element outside range [SMLNUM,BIGNUM] +C + BNRM = DLANGE( 'M', N, N, B, LDB, DWORK ) + ILBSCL = .FALSE. + IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN + BNRMTO = SMLNUM + ILBSCL = .TRUE. + ELSE IF( BNRM.GT.BIGNUM ) THEN + BNRMTO = BIGNUM + ILBSCL = .TRUE. + END IF + IF( ILBSCL ) + $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, + $ IERR ) +C +C Scale E if max element outside range [SMLNUM,BIGNUM] +C + ENRM = DLANGE( 'M', N, N, E, LDE, DWORK ) + ILESCL = .FALSE. + IF( ENRM.GT.ZERO .AND. ENRM.LT.SMLNUM ) THEN + ENRMTO = SMLNUM + ILESCL = .TRUE. + ELSE IF( ENRM.GT.BIGNUM ) THEN + ENRMTO = BIGNUM + ILESCL = .TRUE. + END IF + IF( ILESCL ) + $ CALL DLASCL( 'G', 0, 0, ENRM, ENRMTO, N, N, E, LDE, + $ IERR ) +C +C Reduce (B,E) to generalized Schur form. +C Workspace: need 7*N; +C prefer 5*N + N*(NB+1). +C + CALL DGEGS( 'Vectors left', 'Vectors right', N, B, LDB, E, + $ LDE, DWORK, DWORK(N+1), DWORK(2*N+1), U, LDU, V, + $ LDV, DWORK(3*N+1), LDWORK-3*N, INFO ) +C +C Undo scaling +C + IF( ILBSCL ) + $ CALL DLASCL( 'H', 0, 0, BNRMTO, BNRM, N, N, B, LDB, + $ IERR ) +C + IF( ILESCL ) + $ CALL DLASCL( 'U', 0, 0, ENRMTO, ENRM, N, N, E, LDE, + $ IERR ) +C + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(3*N+1) ) + 3*N ) + END IF + END IF +C + IF (.NOT.LREDUR ) THEN +C +C Set INFO = 2 if A and/or B are/is not in quasi-triangular form. +C + IF (.NOT.LREDUA ) THEN + I = 1 +C + 20 CONTINUE + IF ( I.LE.M-2 ) THEN + IF ( A(I+1,I).NE.ZERO ) THEN + IF ( A(I+2,I+1).NE.ZERO ) THEN + INFO = 2 + RETURN + ELSE + I = I + 1 + END IF + END IF + I = I + 1 + GO TO 20 + END IF + END IF +C + IF (.NOT.LREDUB ) THEN + I = 1 +C + 40 CONTINUE + IF ( I.LE.N-2 ) THEN + IF ( B(I+1,I).NE.ZERO ) THEN + IF ( B(I+2,I+1).NE.ZERO ) THEN + INFO = 2 + RETURN + ELSE + I = I + 1 + END IF + END IF + I = I + 1 + GO TO 40 + END IF + END IF + END IF +C +C STEP 2: Modify right hand sides (C,F). +C + IF ( LREDUC ) THEN + WRKOPT = MAX( WRKOPT, M*N ) + IF ( SUFWRK ) THEN +C +C Enough workspace for a BLAS 3 calculation. +C + IF ( LTRANN ) THEN +C +C Equation (1). +C + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, + $ P, LDP, C, LDC, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) + END IF + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, + $ P, LDP, F, LDF, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) + END IF + ELSE +C +C Equation (2). +C + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, + $ Q, LDQ, C, LDC, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) + END IF + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, + $ P, LDP, F, LDF, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, N, + $ ONE, DWORK, M, U, LDU, ZERO, F, LDF ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) + END IF + END IF + ELSE +C +C Use a BLAS 2 calculation. +C + IF ( LTRANN ) THEN +C +C Equation (1). +C + IF ( .NOT.LREDUB ) THEN +C + DO 60 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, C(1,I), + $ 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) + 60 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 80 I = 1, M + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, C(I,1), + $ LDC, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) + 80 CONTINUE +C + END IF + IF ( .NOT.LREDUB ) THEN +C + DO 100 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, F(1,I), + $ 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) + 100 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 120 I = 1, M + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, F(I,1), + $ LDF, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) + 120 CONTINUE +C + END IF + ELSE +C +C Equation (2). +C + IF ( .NOT.LREDUB ) THEN +C + DO 140 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Q, LDQ, C(1,I), + $ 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) + 140 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 160 I = 1, M + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, C(I,1), + $ LDC, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) + 160 CONTINUE +C + END IF + IF ( .NOT.LREDUB ) THEN +C + DO 180 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, P, LDP, F(1,I), + $ 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) + 180 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 200 I = 1, M + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, F(I,1), + $ LDF, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) + 200 CONTINUE +C + END IF + END IF + END IF + END IF +C +C STEP 3: Solve the transformed system and compute the Dif +C estimator. +C + IF ( LTRANN ) THEN + IF ( LJOBD ) THEN + IJOB = 1 + ELSE IF ( LJOBF ) THEN + IJOB = 2 + ELSE IF ( LJOB1 ) THEN + IJOB = 3 + ELSE IF ( LJOB2 ) THEN + IJOB = 4 + ELSE + IJOB = 0 + END IF + ELSE + IJOB = 0 + END IF +C +C Workspace: need 2*M*N if TRANS = 'N' and JOBD = 'D' or 'F'; +C 1, otherwise. +C + CALL DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, + $ E, LDE, F, LDF, SCALE, DIF, DWORK, LDWORK, IWORK, + $ INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 3 + RETURN + END IF + IF ( LTRANN ) THEN + IF ( LJOBD.OR.LJOBF ) + $ WRKOPT = MAX( WRKOPT, 2*M*N ) + END IF +C +C STEP 4: Back transformation of the solution. +C + IF ( LREDUC ) THEN + IF (SUFWRK ) THEN +C +C Enough workspace for a BLAS 3 calculation. +C + IF ( LTRANN ) THEN +C +C Equation (1). +C + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, M, + $ ONE, Q, LDQ, C, LDC, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, + $ DWORK, M, V, LDV, ZERO, C, LDC ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) + END IF + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, M, + $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, ONE, + $ DWORK, M, U, LDU, ZERO, F, LDF ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) + END IF + ELSE +C +C Equation (2). +C + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, M, + $ ONE, P, LDP, C, LDC, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, C, LDC, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, C, LDC ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, C, LDC ) + END IF + IF ( .NOT.LREDUB ) THEN + CALL DGEMM( 'No transpose', 'No transpose', M, N, M, + $ ONE, P, LDP, F, LDF, ZERO, DWORK, M ) + ELSE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK, M ) + END IF + IF ( .NOT.LREDUA ) THEN + CALL DGEMM( 'No transpose', 'Transpose', M, N, N, + $ ONE, DWORK, M, V, LDV, ZERO, F, LDF ) + ELSE + CALL DLACPY( 'Full', M, N, DWORK, M, F, LDF ) + END IF + END IF + ELSE +C +C Use a BLAS 2 calculation. +C + IF ( LTRANN ) THEN +C +C Equation (1). +C + IF ( .NOT.LREDUB ) THEN +C + DO 220 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Q, LDQ, + $ C(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) + 220 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 240 I = 1, M + CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, + $ C(I,1), LDC, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) + 240 CONTINUE +C + END IF + IF ( .NOT.LREDUB ) THEN +C + DO 260 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, + $ F(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) + 260 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 280 I = 1, M + CALL DGEMV( 'No transpose', N, N, ONE, U, LDU, + $ F(I,1), LDF, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) + 280 CONTINUE +C + END IF + ELSE +C +C Equation (2). +C + IF ( .NOT.LREDUB ) THEN +C + DO 300 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, + $ C(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, C(1,I), 1 ) + 300 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 320 I = 1, M + CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, + $ C(I,1), LDC, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, C(I,1), LDC ) + 320 CONTINUE +C + END IF + IF ( .NOT.LREDUB ) THEN +C + DO 340 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, P, LDP, + $ F(1,I), 1, ZERO, DWORK, 1 ) + CALL DCOPY( M, DWORK, 1, F(1,I), 1 ) + 340 CONTINUE +C + END IF + IF ( .NOT.LREDUA ) THEN +C + DO 360 I = 1, M + CALL DGEMV( 'No transpose', N, N, ONE, V, LDV, + $ F(I,1), LDF, ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, F(I,1), LDF ) + 360 CONTINUE +C + END IF + END IF + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB04OD *** + END diff --git a/mex/sources/libslicot/SB04OW.f b/mex/sources/libslicot/SB04OW.f new file mode 100644 index 000000000..c3d613afd --- /dev/null +++ b/mex/sources/libslicot/SB04OW.f @@ -0,0 +1,568 @@ + SUBROUTINE SB04OW( M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, + $ F, LDF, SCALE, IWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a periodic Sylvester equation +C +C A * R - L * B = scale * C (1) +C D * L - R * E = scale * F, +C +C using Level 1 and 2 BLAS, where R and L are unknown M-by-N +C matrices, (A, D), (B, E) and (C, F) are given matrix pairs of +C size M-by-M, N-by-N and M-by-N, respectively, with real entries. +C (A, D) and (B, E) must be in periodic Schur form, i.e. A, B are +C upper quasi triangular and D, E are upper triangular. The solution +C (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output scaling +C factor chosen to avoid overflow. +C +C This routine is largely based on the LAPACK routine DTGSY2 +C developed by Bo Kagstrom and Peter Poromaa. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of A and D, and the row dimension of C, F, R +C and L. M >= 0. +C +C N (input) INTEGER +C The order of B and E, and the column dimension of C, F, R +C and L. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C On entry, the leading M-by-M part of this array must +C contain the upper quasi triangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the upper quasi triangular matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand-side of the first matrix equation +C in (1). +C On exit, the leading M-by-N part of this array contains +C the solution R. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,M). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading M-by-M part of this array must +C contain the upper triangular matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,M). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the upper triangular matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) +C On entry, the leading M-by-N part of this array must +C contain the right-hand-side of the second matrix equation +C in (1). +C On exit, the leading M-by-N part of this array contains +C the solution L. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the arrays +C C and F will hold the solutions R and L, respectively, to +C a slightly perturbed system but the input matrices A, B, D +C and E have not been changed. If SCALE = 0, C and F will +C hold solutions to the homogeneous system with C = F = 0. +C Normally, SCALE = 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M+N+2) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: the matrix products A*D and B*E have common or very +C close eigenvalues. +C +C METHOD +C +C In matrix notation solving equation (1) corresponds to solving +C Z*x = scale*b, where Z is defined as +C +C Z = [ kron(In, A) -kron(B', Im) ] (2) +C [ -kron(E', Im) kron(In, D) ], +C +C Ik is the identity matrix of size k and X' is the transpose of X. +C kron(X, Y) is the Kronecker product between the matrices X and Y. +C In the process of solving (1), we solve a number of such systems +C where Dim(Im), Dim(In) = 1 or 2. +C +C REFERENCES +C +C [1] Kagstrom, B. +C A Direct Method for Reordering Eigenvalues in the Generalized +C Real Schur Form of a Regular Matrix Pair (A,B). M.S. Moonen +C et al (eds.), Linear Algebra for Large Scale and Real-Time +C Applications, Kluwer Academic Publ., pp. 195-218, 1993. +C +C [2] Sreedhar, J. and Van Dooren, P. +C A Schur approach for solving some periodic matrix equations. +C U. Helmke et al (eds.), Systems and Networks: Mathematical +C Theory and Applications, Akademie Verlag, Berlin, vol. 77, +C pp. 339-362, 1994. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine DTGPY2). +C +C KEYWORDS +C +C Matrix equation, periodic Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER LDZ + PARAMETER ( LDZ = 8 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N + DOUBLE PRECISION SCALE +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ E(LDE,*), F(LDF,*) +C .. Local Scalars .. + INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, + $ K, MB, NB, P, Q, ZDIM + DOUBLE PRECISION SCALOC +C .. Local Arrays .. + INTEGER IPIV(LDZ), JPIV(LDZ) + DOUBLE PRECISION RHS(LDZ), Z(LDZ,LDZ) +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, + $ DGETC2, DLASET, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + INFO = 0 + IERR = 0 + IF ( M.LE.0 ) THEN + INFO = -1 + ELSE IF ( N.LE.0 ) THEN + INFO = -2 + ELSE IF ( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + ELSE IF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF ( LDC.LT.MAX( 1, M ) ) THEN + INFO = -8 + ELSE IF ( LDD.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF ( LDE.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF ( LDF.LT.MAX( 1, M ) ) THEN + INFO = -14 + END IF +C +C Return if there were illegal values. +C + IF ( INFO.NE.0 ) THEN + CALL XERBLA( 'SB04OW', -INFO ) + RETURN + END IF +C +C Determine block structure of A. +C + P = 0 + I = 1 + 10 CONTINUE + IF ( I.GT.M ) + $ GO TO 20 + P = P + 1 + IWORK(P) = I + IF( I.EQ.M ) + $ GO TO 20 + IF ( A(I+1,I).NE.ZERO ) THEN + I = I + 2 + ELSE + I = I + 1 + END IF + GO TO 10 + 20 CONTINUE + IWORK(P+1) = M + 1 +C +C Determine block structure of B. +C + Q = P + 1 + J = 1 + 30 CONTINUE + IF ( J.GT.N ) + $ GO TO 40 + Q = Q + 1 + IWORK(Q) = J + IF( J.EQ.N ) + $ GO TO 40 + IF ( B(J+1,J).NE.ZERO ) THEN + J = J + 2 + ELSE + J = J + 1 + END IF + GO TO 30 + 40 CONTINUE + IWORK(Q+1) = N + 1 +C +C Solve (I, J) - subsystem +C A(I,I) * R(I,J) - L(I,J) * B(J,J) = C(I,J) +C D(I,I) * L(I,J) - R(I,J) * E(J,J) = F(I,J) +C for I = P, P - 1, ..., 1; J = 1, 2, ..., Q. +C + SCALE = ONE + SCALOC = ONE + DO 120 J = P + 2, Q + JS = IWORK(J) + JSP1 = JS + 1 + JE = IWORK(J+1) - 1 + NB = JE - JS + 1 + DO 110 I = P, 1, -1 +C + IS = IWORK(I) + ISP1 = IS + 1 + IE = IWORK(I+1) - 1 + MB = IE - IS + 1 + ZDIM = MB*NB*2 +C + IF ( ( MB.EQ.1 ).AND.( NB.EQ.1 ) ) THEN +C +C Build a 2-by-2 system Z * x = RHS. +C + Z(1,1) = A(IS,IS) + Z(2,1) = -E(JS,JS) + Z(1,2) = -B(JS,JS) + Z(2,2) = D(IS,IS) +C +C Set up right hand side(s). +C + RHS(1) = C(IS,JS) + RHS(2) = F(IS,JS) +C +C Solve Z * x = RHS. +C + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF ( IERR.GT.0 ) + $ INFO = IERR +C + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF ( SCALOC.NE.ONE ) THEN + DO 50 K = 1, N + CALL DSCAL( M, SCALOC, C(1,K), 1 ) + CALL DSCAL( M, SCALOC, F(1,K), 1 ) + 50 CONTINUE + SCALE = SCALE*SCALOC + END IF +C +C Unpack solution vector(s). +C + C(IS,JS) = RHS(1) + F(IS,JS) = RHS(2) +C +C Substitute R(I,J) and L(I,J) into remaining equation. +C + IF ( I.GT.1 ) THEN + CALL DAXPY( IS-1, -RHS(1), A(1,IS), 1, C(1,JS), 1 ) + CALL DAXPY( IS-1, -RHS(2), D(1,IS), 1, F(1,JS), 1 ) + END IF + IF ( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS(2), B(JS,JE+1), LDB, C(IS,JE+1), + $ LDC ) + CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1), + $ LDF ) + END IF +C + ELSE IF ( ( MB.EQ.1 ).AND.( NB.EQ.2 ) ) THEN +C +C Build a 4-by-4 system Z * x = RHS. +C + Z(1,1) = A(IS,IS) + Z(2,1) = ZERO + Z(3,1) = -E(JS,JS) + Z(4,1) = -E(JS,JSP1) +C + Z(1,2) = ZERO + Z(2,2) = A(IS,IS) + Z(3,2) = ZERO + Z(4,2) = -E(JSP1,JSP1) +C + Z(1,3) = -B(JS,JS) + Z(2,3) = -B(JS,JSP1) + Z(3,3) = D(IS,IS) + Z(4,3) = ZERO +C + Z(1,4) = -B(JSP1,JS) + Z(2,4) = -B(JSP1,JSP1) + Z(3,4) = ZERO + Z(4,4) = D(IS,IS) +C +C Set up right hand side(s). +C + RHS(1) = C(IS,JS) + RHS(2) = C(IS,JSP1) + RHS(3) = F(IS,JS) + RHS(4) = F(IS,JSP1) +C +C Solve Z * x = RHS. +C + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF ( IERR.GT.0 ) + $ INFO = IERR +C + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF ( SCALOC.NE.ONE ) THEN + DO 60 K = 1, N + CALL DSCAL( M, SCALOC, C(1,K), 1 ) + CALL DSCAL( M, SCALOC, F(1,K), 1 ) + 60 CONTINUE + SCALE = SCALE*SCALOC + END IF +C +C Unpack solution vector(s). +C + C(IS,JS) = RHS(1) + C(IS,JSP1) = RHS(2) + F(IS,JS) = RHS(3) + F(IS,JSP1) = RHS(4) +C +C Substitute R(I,J) and L(I,J) into remaining equation. +C + IF ( I.GT.1 ) THEN + CALL DGER( IS-1, NB, -ONE, A(1,IS), 1, RHS(1), 1, + $ C(1,JS), LDC ) + CALL DGER( IS-1, NB, -ONE, D(1,IS), 1, RHS(3), 1, + $ F(1,JS), LDF ) + END IF + IF ( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS(3), B(JS,JE+1), LDB, C(IS,JE+1), + $ LDC ) + CALL DAXPY( N-JE, RHS(1), E(JS,JE+1), LDE, F(IS,JE+1), + $ LDF ) + CALL DAXPY( N-JE, RHS(4), B(JSP1,JE+1), LDB, + $ C(IS,JE+1), LDC ) + CALL DAXPY( N-JE, RHS(2), E(JSP1,JE+1), LDE, + $ F(IS,JE+1), LDF ) + END IF +C + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN +C +C Build a 4-by-4 system Z * x = RHS. +C + Z(1,1) = A(IS,IS) + Z(2,1) = A(ISP1,IS) + Z(3,1) = -E(JS,JS) + Z(4,1) = ZERO +C + Z(1,2) = A(IS,ISP1) + Z(2,2) = A(ISP1,ISP1) + Z(3,2) = ZERO + Z(4,2) = -E(JS,JS) +C + Z(1,3) = -B(JS,JS) + Z(2,3) = ZERO + Z(3,3) = D(IS,IS) + Z(4,3) = ZERO +C + Z(1,4) = ZERO + Z(2,4) = -B(JS,JS) + Z(3,4) = D(IS,ISP1) + Z(4,4) = D(ISP1,ISP1) +C +C Set up right hand side(s). +C + RHS(1) = C(IS,JS) + RHS(2) = C(ISP1,JS) + RHS(3) = F(IS,JS) + RHS(4) = F(ISP1,JS) +C +C Solve Z * x = RHS. +C + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF ( IERR.GT.0 ) + $ INFO = IERR +C + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF ( SCALOC.NE.ONE ) THEN + DO 70 K = 1, N + CALL DSCAL( M, SCALOC, C(1,K), 1 ) + CALL DSCAL( M, SCALOC, F(1,K), 1 ) + 70 CONTINUE + SCALE = SCALE*SCALOC + END IF +C +C Unpack solution vector(s). +C + C(IS,JS) = RHS(1) + C(ISP1,JS) = RHS(2) + F(IS,JS) = RHS(3) + F(ISP1,JS) = RHS(4) +C +C Substitute R(I,J) and L(I,J) into remaining equation. +C + IF ( I.GT.1 ) THEN + CALL DGEMV( 'N', IS-1, MB, -ONE, A(1,IS), LDA, RHS(1), + $ 1, ONE, C(1,JS), 1 ) + CALL DGEMV( 'N', IS-1, MB, -ONE, D(1,IS), LDD, RHS(3), + $ 1, ONE, F(1,JS), 1 ) + END IF + IF ( J.LT.Q ) THEN + CALL DGER( MB, N-JE, ONE, RHS(3), 1, B(JS,JE+1), LDB, + $ C(IS,JE+1), LDC ) + CALL DGER( MB, N-JE, ONE, RHS(1), 1, E(JS,JE+1), LDE, + $ F(IS,JE+1), LDF ) + END IF +C + ELSE IF ( ( MB.EQ.2 ).AND.( NB.EQ.2 ) ) THEN +C +C Build an 8-by-8 system Z * x = RHS. +C + CALL DLASET( 'All', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) +C + Z(1,1) = A(IS,IS) + Z(2,1) = A(ISP1,IS) + Z(5,1) = -E(JS,JS) + Z(7,1) = -E(JS,JSP1) +C + Z(1,2) = A(IS,ISP1) + Z(2,2) = A(ISP1,ISP1) + Z(6,2) = -E(JS,JS) + Z(8,2) = -E(JS,JSP1) +C + Z(3,3) = A(IS,IS) + Z(4,3) = A(ISP1,IS) + Z(7,3) = -E(JSP1,JSP1) +C + Z(3,4) = A(IS,ISP1) + Z(4,4) = A(ISP1,ISP1) + Z(8,4) = -E(JSP1,JSP1) +C + Z(1,5) = -B(JS,JS) + Z(3,5) = -B(JS,JSP1) + Z(5,5) = D(IS,IS) +C + Z(2,6) = -B(JS,JS) + Z(4,6) = -B(JS,JSP1) + Z(5,6) = D(IS,ISP1) + Z(6,6) = D(ISP1,ISP1) +C + Z(1,7) = -B(JSP1,JS) + Z(3,7) = -B(JSP1,JSP1) + Z(7,7) = D(IS,IS) +C + Z(2,8) = -B(JSP1,JS) + Z(4,8) = -B(JSP1,JSP1) +C + Z(7,8) = D(IS,ISP1) + Z(8,8) = D(ISP1,ISP1) +C +C Set up right hand side(s). +C + K = 1 + II = MB*NB + 1 + DO 80 JJ = 0, NB - 1 + CALL DCOPY( MB, C(IS,JS+JJ), 1, RHS(K), 1 ) + CALL DCOPY( MB, F(IS,JS+JJ), 1, RHS(II), 1 ) + K = K + MB + II = II + MB + 80 CONTINUE +C +C Solve Z * x = RHS. +C + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF ( IERR.GT.0 ) + $ INFO = IERR +C + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF ( SCALOC.NE.ONE ) THEN + DO 90 K = 1, N + CALL DSCAL( M, SCALOC, C(1,K), 1 ) + CALL DSCAL( M, SCALOC, F(1,K), 1 ) + 90 CONTINUE + SCALE = SCALE*SCALOC + END IF +C +C Unpack solution vector(s). +C + K = 1 + II = MB*NB + 1 + DO 100 JJ = 0, NB - 1 + CALL DCOPY( MB, RHS(K), 1, C(IS,JS+JJ), 1 ) + CALL DCOPY( MB, RHS(II), 1, F(IS,JS+JJ), 1 ) + K = K + MB + II = II + MB + 100 CONTINUE +C +C Substitute R(I,J) and L(I,J) into remaining equation. +C + K = MB*NB + 1 + IF ( I.GT.1 ) THEN + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, A(1,IS), + $ LDA, RHS(1), MB, ONE, C(1,JS), LDC ) + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, D(1,IS), + $ LDD, RHS(K), MB, ONE, F(1,JS), LDF ) + END IF + IF ( J.LT.Q ) THEN + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(K), MB, + $ B(JS,JE+1), LDB, ONE, C(IS,JE+1), LDC ) + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS(1), MB, + $ E(JS,JE+1), LDE, ONE, F(IS,JE+1), LDF ) + END IF +C + END IF +C + 110 CONTINUE + 120 CONTINUE + RETURN +C *** Last line of SB04OW *** + END diff --git a/mex/sources/libslicot/SB04PD.f b/mex/sources/libslicot/SB04PD.f new file mode 100644 index 000000000..a2e5899a4 --- /dev/null +++ b/mex/sources/libslicot/SB04PD.f @@ -0,0 +1,672 @@ + SUBROUTINE SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, M, N, + $ A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the real continuous-time Sylvester equation +C +C op(A)*X + ISGN*X*op(B) = scale*C, (1) +C +C or the real discrete-time Sylvester equation +C +C op(A)*X*op(B) + ISGN*X = scale*C, (2) +C +C where op(M) = M or M**T, and ISGN = 1 or -1. A is M-by-M and +C B is N-by-N; the right hand side C and the solution X are M-by-N; +C and scale is an output scale factor, set less than or equal to 1 +C to avoid overflow in X. The solution matrix X is overwritten +C onto C. +C +C If A and/or B are not (upper) quasi-triangular, that is, block +C upper triangular with 1-by-1 and 2-by-2 diagonal blocks, they are +C reduced to Schur canonical form, that is, quasi-triangular with +C each 2-by-2 diagonal block having its diagonal elements equal and +C its off-diagonal elements of opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the equation from which X is to be determined +C as follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C FACTA CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix A is supplied on entry, as follows: +C = 'F': On entry, A and U contain the factors from the +C real Schur factorization of the matrix A; +C = 'N': The Schur factorization of A will be computed +C and the factors will be stored in A and U; +C = 'S': The matrix A is quasi-triangular (or Schur). +C +C FACTB CHARACTER*1 +C Specifies whether or not the real Schur factorization +C of the matrix B is supplied on entry, as follows: +C = 'F': On entry, B and V contain the factors from the +C real Schur factorization of the matrix B; +C = 'N': The Schur factorization of B will be computed +C and the factors will be stored in B and V; +C = 'S': The matrix B is quasi-triangular (or Schur). +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C TRANB CHARACTER*1 +C Specifies the form of op(B) to be used, as follows: +C = 'N': op(B) = B (No transpose); +C = 'T': op(B) = B**T (Transpose); +C = 'C': op(B) = B**T (Conjugate transpose = Transpose). +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A, and the number of rows in the +C matrices X and C. M >= 0. +C +C N (input) INTEGER +C The order of the matrix B, and the number of columns in +C the matrices X and C. N >= 0. +C +C A (input or input/output) DOUBLE PRECISION array, +C dimension (LDA,M) +C On entry, the leading M-by-M part of this array must +C contain the matrix A. If FACTA = 'S', then A contains +C a quasi-triangular matrix, and if FACTA = 'F', then A +C is in Schur canonical form; the elements below the upper +C Hessenberg part of the array A are not referenced. +C On exit, if FACTA = 'N', and INFO = 0 or INFO >= M+1, the +C leading M-by-M upper Hessenberg part of this array +C contains the upper quasi-triangular matrix in Schur +C canonical form from the Schur factorization of A. The +C contents of array A is not modified if FACTA = 'F' or 'S'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C U (input or output) DOUBLE PRECISION array, dimension +C (LDU,M) +C If FACTA = 'F', then U is an input argument and on entry +C the leading M-by-M part of this array must contain the +C orthogonal matrix U of the real Schur factorization of A. +C If FACTA = 'N', then U is an output argument and on exit, +C if INFO = 0 or INFO >= M+1, it contains the orthogonal +C M-by-M matrix from the real Schur factorization of A. +C If FACTA = 'S', the array U is not referenced. +C +C LDU INTEGER +C The leading dimension of array U. +C LDU >= MAX(1,M), if FACTA = 'F' or 'N'; +C LDU >= 1, if FACTA = 'S'. +C +C B (input or input/output) DOUBLE PRECISION array, +C dimension (LDB,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix B. If FACTB = 'S', then B contains +C a quasi-triangular matrix, and if FACTB = 'F', then B +C is in Schur canonical form; the elements below the upper +C Hessenberg part of the array B are not referenced. +C On exit, if FACTB = 'N', and INFO = 0 or INFO = M+N+1, +C the leading N-by-N upper Hessenberg part of this array +C contains the upper quasi-triangular matrix in Schur +C canonical form from the Schur factorization of B. The +C contents of array B is not modified if FACTB = 'F' or 'S'. +C +C LDB (input) INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C V (input or output) DOUBLE PRECISION array, dimension +C (LDV,N) +C If FACTB = 'F', then V is an input argument and on entry +C the leading N-by-N part of this array must contain the +C orthogonal matrix V of the real Schur factorization of B. +C If FACTB = 'N', then V is an output argument and on exit, +C if INFO = 0 or INFO = M+N+1, it contains the orthogonal +C N-by-N matrix from the real Schur factorization of B. +C If FACTB = 'S', the array V is not referenced. +C +C LDV INTEGER +C The leading dimension of array V. +C LDV >= MAX(1,N), if FACTB = 'F' or 'N'; +C LDV >= 1, if FACTB = 'S'. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right hand side matrix C. +C On exit, if INFO = 0 or INFO = M+N+1, the leading M-by-N +C part of this array contains the solution matrix X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0 or M+N+1, then: DWORK(1) returns the +C optimal value of LDWORK; if FACTA = 'N', DWORK(1+i) and +C DWORK(1+M+i), i = 1,...,M, contain the real and imaginary +C parts, respectively, of the eigenvalues of A; and, if +C FACTB = 'N', DWORK(1+f+j) and DWORK(1+f+N+j), j = 1,...,N, +C with f = 2*M if FACTA = 'N', and f = 0, otherwise, contain +C the real and imaginary parts, respectively, of the +C eigenvalues of B. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, a+MAX( c, b+d, b+e ) ), +C where a = 1+2*M, if FACTA = 'N', +C a = 0, if FACTA <> 'N', +C b = 2*N, if FACTB = 'N', FACTA = 'N', +C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', +C b = 0, if FACTB <> 'N', +C c = 3*M, if FACTA = 'N', +C c = M, if FACTA = 'F', +C c = 0, if FACTA = 'S', +C d = 3*N, if FACTB = 'N', +C d = N, if FACTB = 'F', +C d = 0, if FACTB = 'S', +C e = M, if DICO = 'C', FACTA <> 'S', +C e = 0, if DICO = 'C', FACTA = 'S', +C e = 2*M, if DICO = 'D'. +C An upper bound is +C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M ). +C For good performance, LDWORK should be larger, e.g., +C LDWORK = 1+2*M+MAX( 3*M, 5*N, 2*N+2*M, 2*N+M*N ). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = i: if INFO = i, i = 1,...,M, the QR algorithm failed +C to compute all the eigenvalues of the matrix A +C (see LAPACK Library routine DGEES); the elements +C 2+i:1+M and 2+i+M:1+2*M of DWORK contain the real +C and imaginary parts, respectively, of the +C eigenvalues of A which have converged, and the +C array A contains the partially converged Schur form; +C = M+j: if INFO = M+j, j = 1,...,N, the QR algorithm +C failed to compute all the eigenvalues of the matrix +C B (see LAPACK Library routine DGEES); the elements +C 2+f+j:1+f+N and 2+f+j+N:1+f+2*N of DWORK contain the +C real and imaginary parts, respectively, of the +C eigenvalues of B which have converged, and the +C array B contains the partially converged Schur form; +C as defined for the parameter DWORK, +C f = 2*M, if FACTA = 'N', +C f = 0, if FACTA <> 'N'; +C = M+N+1: if DICO = 'C', and the matrices A and -ISGN*B +C have common or very close eigenvalues, or +C if DICO = 'D', and the matrices A and -ISGN*B have +C almost reciprocal eigenvalues (that is, if lambda(i) +C and mu(j) are eigenvalues of A and -ISGN*B, then +C lambda(i) = 1/mu(j) for some i and j); +C perturbed values were used to solve the equation +C (but the matrices A and B are unchanged). +C +C METHOD +C +C An extension and refinement of the algorithms in [1,2] is used. +C If the matrices A and/or B are not quasi-triangular (see PURPOSE), +C they are reduced to Schur canonical form +C +C A = U*S*U', B = V*T*V', +C +C where U, V are orthogonal, and S, T are block upper triangular +C with 1-by-1 and 2-by-2 blocks on their diagonal. The right hand +C side matrix C is updated accordingly, +C +C C = U'*C*V; +C +C then, the solution matrix X of the "reduced" Sylvester equation +C (with A and B in (1) or (2) replaced by S and T, respectively), +C is computed column-wise via a back substitution scheme. A set of +C equivalent linear algebraic systems of equations of order at most +C four are formed and solved using Gaussian elimination with +C complete pivoting. Finally, the solution X of the original +C equation is obtained from the updating formula +C +C X = U*X*V'. +C +C If A and/or B are already quasi-triangular (or in Schur form), the +C initial factorizations and the corresponding updating steps are +C omitted. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since orthogonal +C transformations and Gaussian elimination with complete pivoting +C are used. If INFO = M+N+1, the Sylvester equation is numerically +C singular. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, April 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix algebra, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER DICO, FACTA, FACTB, TRANA, TRANB + INTEGER INFO, ISGN, LDA, LDB, LDC, LDU, LDV, LDWORK, M, + $ N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), U( LDU, * ), V( LDV, * ) +C .. +C .. Local Scalars .. + LOGICAL BLAS3A, BLAS3B, BLOCKA, BLOCKB, CONT, NOFACA, + $ NOFACB, NOTRNA, NOTRNB, SCHURA, SCHURB + INTEGER AVAILW, BL, CHUNKA, CHUNKB, I, IA, IB, IERR, J, + $ JWORK, MAXWRK, MINWRK, SDIM +C .. +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DTRSYL, + $ SB04PY, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters +C + CONT = LSAME( DICO, 'C' ) + NOFACA = LSAME( FACTA, 'N' ) + NOFACB = LSAME( FACTB, 'N' ) + SCHURA = LSAME( FACTA, 'S' ) + SCHURB = LSAME( FACTB, 'S' ) + NOTRNA = LSAME( TRANA, 'N' ) + NOTRNB = LSAME( TRANB, 'N' ) +C + INFO = 0 + IF( .NOT.CONT .AND. .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOFACA .AND. .NOT.LSAME( FACTA, 'F' ) .AND. + $ .NOT.SCHURA ) THEN + INFO = -2 + ELSE IF( .NOT.NOFACB .AND. .NOT.LSAME( FACTB, 'F' ) .AND. + $ .NOT.SCHURB ) THEN + INFO = -3 + ELSE IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -4 + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. + $ .NOT.LSAME( TRANB, 'C' ) ) THEN + INFO = -5 + ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN + INFO = -6 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDU.LT.1 .OR. ( .NOT.SCHURA .AND. LDU.LT.M ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDV.LT.1 .OR. ( .NOT.SCHURB .AND. LDV.LT.N ) ) THEN + INFO = -16 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -18 + ELSE + IF ( NOFACA ) THEN + IA = 1 + 2*M + MINWRK = 3*M + ELSE + IA = 0 + END IF + IF ( SCHURA ) THEN + MINWRK = 0 + ELSE IF ( .NOT.NOFACA ) THEN + MINWRK = M + END IF + IB = 0 + IF ( NOFACB ) THEN + IB = 2*N + IF ( .NOT.NOFACA ) + $ IB = IB + 1 + MINWRK = MAX( MINWRK, IB + 3*N ) + ELSE IF ( .NOT.SCHURB ) THEN + MINWRK = MAX( MINWRK, N ) + END IF + IF ( CONT ) THEN + IF ( .NOT.SCHURA ) + $ MINWRK = MAX( MINWRK, IB + M ) + ELSE + MINWRK = MAX( MINWRK, IB + 2*M ) + END IF + MINWRK = MAX( 1, IA + MINWRK ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -21 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB04PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + SCALE = ONE + DWORK( 1 ) = ONE + RETURN + END IF + MAXWRK = MINWRK +C + IF( NOFACA ) THEN +C +C Compute the Schur factorization of A. +C Workspace: need 1+5*M; +C prefer larger. +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + JWORK = 2*M + 2 + IA = JWORK + AVAILW = LDWORK - JWORK + 1 + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, A, LDA, SDIM, + $ DWORK( 2 ), DWORK( M+2 ), U, LDU, DWORK( JWORK ), + $ AVAILW, BWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) + ELSE + JWORK = 1 + IA = 2 + AVAILW = LDWORK + END IF +C + IF( .NOT.SCHURA ) THEN +C +C Transform the right-hand side: C <-- U'*C. +C Workspace: need a+M, +C prefer a+M*N, +C where a = 1+2*M, if FACTA = 'N', +C a = 0, if FACTA <> 'N'. +C + CHUNKA = AVAILW / M + BLOCKA = MIN( CHUNKA, N ).GT.1 + BLAS3A = CHUNKA.GE.N .AND. BLOCKA +C + IF ( BLAS3A ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) + ELSE IF ( BLOCKA ) THEN +C +C Use as many columns of C as possible. +C + DO 10 J = 1, N, CHUNKA + BL = MIN( N-J+1, CHUNKA ) + CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, + $ DWORK( JWORK ), M ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, BL, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), + $ LDC ) + 10 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 20 J = 1, N + CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) + CALL DGEMV( 'Transpose', M, M, ONE, U, LDU, + $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) + 20 CONTINUE +C + END IF + MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) + END IF +C + IF( NOFACB ) THEN +C +C Compute the Schur factorization of B. +C Workspace: need 1+MAX(a-1,0)+5*N, +C prefer larger. +C + JWORK = IA + 2*N + AVAILW = LDWORK - JWORK + 1 + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, B, LDB, SDIM, + $ DWORK( IA ), DWORK( N+IA ), V, LDV, DWORK( JWORK ), + $ AVAILW, BWORK, IERR ) + IF( IERR.GT.0 ) THEN + INFO = IERR + M + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 ) +C + IF( .NOT.SCHURA ) THEN +C +C Recompute the blocking parameters. +C + CHUNKA = AVAILW / M + BLOCKA = MIN( CHUNKA, N ).GT.1 + BLAS3A = CHUNKA.GE.N .AND. BLOCKA + END IF + END IF +C + IF( .NOT.SCHURB ) THEN +C +C Transform the right-hand side: C <-- C*V. +C Workspace: need a+b+N, +C prefer a+b+M*N, +C where b = 2*N, if FACTB = 'N', FACTA = 'N', +C b = 1+2*N, if FACTB = 'N', FACTA <> 'N', +C b = 0, if FACTB <> 'N'. +C + CHUNKB = AVAILW / N + BLOCKB = MIN( CHUNKB, M ).GT.1 + BLAS3B = CHUNKB.GE.M .AND. BLOCKB +C + IF ( BLAS3B ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, + $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) + ELSE IF ( BLOCKB ) THEN +C +C Use as many rows of C as possible. +C + DO 30 I = 1, M, CHUNKB + BL = MIN( M-I+1, CHUNKB ) + CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, + $ DWORK( JWORK ), BL ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, + $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), + $ LDC ) + 30 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 40 I = 1, M + CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, V, LDV, + $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) + 40 CONTINUE +C + END IF + MAXWRK = MAX( MAXWRK, JWORK + M*N - 1 ) + END IF +C +C Solve the (transformed) equation. +C Workspace for DICO = 'D': a+b+2*M. +C + IF ( CONT ) THEN + CALL DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, + $ SCALE, IERR ) + ELSE + CALL SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, + $ SCALE, DWORK( JWORK ), IERR ) + MAXWRK = MAX( MAXWRK, JWORK + 2*M - 1 ) + END IF + IF( IERR.GT.0 ) + $ INFO = M + N + 1 +C +C Transform back the solution, if needed. +C + IF( .NOT.SCHURA ) THEN +C +C Transform the right-hand side: C <-- U*C. +C Workspace: need a+b+M; +C prefer a+b+M*N. +C + IF ( BLAS3A ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C, LDC ) + ELSE IF ( BLOCKA ) THEN +C +C Use as many columns of C as possible. +C + DO 50 J = 1, N, CHUNKA + BL = MIN( N-J+1, CHUNKA ) + CALL DLACPY( 'Full', M, BL, C( 1, J ), LDC, + $ DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, BL, M, ONE, + $ U, LDU, DWORK( JWORK ), M, ZERO, C( 1, J ), + $ LDC ) + 50 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 60 J = 1, N + CALL DCOPY( M, C( 1, J ), 1, DWORK( JWORK ), 1 ) + CALL DGEMV( 'NoTranspose', M, M, ONE, U, LDU, + $ DWORK( JWORK ), 1, ZERO, C( 1, J ), 1 ) + 60 CONTINUE +C + END IF + END IF +C + IF( .NOT.SCHURB ) THEN +C +C Transform the right-hand side: C <-- C*V'. +C Workspace: need a+b+N; +C prefer a+b+M*N. +C + IF ( BLAS3B ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', M, N, C, LDC, DWORK( JWORK ), M ) + CALL DGEMM( 'NoTranspose', 'Transpose', M, N, N, ONE, + $ DWORK( JWORK ), M, V, LDV, ZERO, C, LDC ) + ELSE IF ( BLOCKB ) THEN +C +C Use as many rows of C as possible. +C + DO 70 I = 1, M, CHUNKB + BL = MIN( M-I+1, CHUNKB ) + CALL DLACPY( 'Full', BL, N, C( I, 1 ), LDC, + $ DWORK( JWORK ), BL ) + CALL DGEMM( 'NoTranspose', 'Transpose', BL, N, N, ONE, + $ DWORK( JWORK ), BL, V, LDV, ZERO, C( I, 1 ), + $ LDC ) + 70 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. +C + DO 80 I = 1, M + CALL DCOPY( N, C( I, 1 ), LDC, DWORK( JWORK ), 1 ) + CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, + $ DWORK( JWORK ), 1, ZERO, C( I, 1 ), LDC ) + 80 CONTINUE +C + END IF + END IF +C + DWORK( 1 ) = DBLE( MAXWRK ) +C + RETURN +C *** Last line of SB04PD *** + END diff --git a/mex/sources/libslicot/SB04PX.f b/mex/sources/libslicot/SB04PX.f new file mode 100644 index 000000000..99bd63d3b --- /dev/null +++ b/mex/sources/libslicot/SB04PX.f @@ -0,0 +1,468 @@ + 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-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To 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 diff --git a/mex/sources/libslicot/SB04PY.f b/mex/sources/libslicot/SB04PY.f new file mode 100644 index 000000000..46b81f880 --- /dev/null +++ b/mex/sources/libslicot/SB04PY.f @@ -0,0 +1,1111 @@ + SUBROUTINE SB04PY( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, + $ LDC, SCALE, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C op(A)*X*op(B) + ISGN*X = scale*C, +C +C where op(A) = A or A**T, A and B are both upper quasi-triangular, +C and ISGN = 1 or -1. A is M-by-M and B is N-by-N; the right hand +C side C and the solution X are M-by-N; and scale is an output scale +C factor, set less than or equal to 1 to avoid overflow in X. The +C solution matrix X is overwritten onto C. +C +C A and B must be in Schur canonical form (as returned by LAPACK +C Library routine DHSEQR), that is, block upper triangular with +C 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block has +C its diagonal elements equal and its off-diagonal elements of +C opposite sign. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANA CHARACTER*1 +C Specifies the form of op(A) to be used, as follows: +C = 'N': op(A) = A (No transpose); +C = 'T': op(A) = A**T (Transpose); +C = 'C': op(A) = A**T (Conjugate transpose = Transpose). +C +C TRANB CHARACTER*1 +C Specifies the form of op(B) to be used, as follows: +C = 'N': op(B) = B (No transpose); +C = 'T': op(B) = B**T (Transpose); +C = 'C': op(B) = B**T (Conjugate transpose = Transpose). +C +C ISGN INTEGER +C Specifies the sign of the equation as described before. +C ISGN may only be 1 or -1. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A, and the number of rows in the +C matrices X and C. M >= 0. +C +C N (input) INTEGER +C The order of the matrix B, and the number of columns in +C the matrices X and C. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain the +C upper quasi-triangular matrix A, in Schur canonical form. +C The part of A below the first sub-diagonal is not +C referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain the +C upper quasi-triangular matrix B, in Schur canonical form. +C The part of B below the first sub-diagonal is not +C referenced. +C +C LDB (input) INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the right hand side matrix C. +C On exit, if INFO >= 0, the leading M-by-N part of this +C array contains the solution matrix X. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor, scale, set less than or equal to 1 to +C prevent the solution overflowing. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: A and -ISGN*B have almost reciprocal eigenvalues; +C perturbed values were used to solve the equation +C (but the matrices A and B are unchanged). +C +C METHOD +C +C The solution matrix X is computed column-wise via a back +C substitution scheme, an extension and refinement of the algorithm +C in [1], similar to that used in [2] for continuous-time Sylvester +C equations. A set of equivalent linear algebraic systems of +C equations of order at most four are formed and solved using +C Gaussian elimination with complete pivoting. +C +C REFERENCES +C +C [1] Bartels, R.H. and Stewart, G.W. T +C Solution of the matrix equation A X + XB = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C The algorithm is stable and reliable, since Gaussian elimination +C with complete pivoting is used. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, March 2000. +C D. Sima, University of Bucharest, April 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000. +C Partly based on the routine SYLSV, A. Varga, 1992. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, matrix algebra, Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER TRANA, TRANB + INTEGER INFO, ISGN, LDA, LDB, LDC, M, N + DOUBLE PRECISION SCALE +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ) +C .. +C .. Local Scalars .. + LOGICAL NOTRNA, NOTRNB + INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT, + $ MNK1, MNK2, MNL1, MNL2 + DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, P11, P12, P21, P22, + $ SCALOC, SGN, SMIN, SMLNUM, SUMR, XNORM +C .. +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 ) +C .. +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT, DLAMCH, DLANGE + EXTERNAL DDOT, DLAMCH, DLANGE, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DLABAD, DLALN2, DSCAL, SB04PX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters +C + NOTRNA = LSAME( TRANA, 'N' ) + NOTRNB = LSAME( TRANB, 'N' ) +C + INFO = 0 + IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. + $ .NOT.LSAME( TRANA, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. + $ .NOT.LSAME( TRANB, 'C' ) ) THEN + INFO = -2 + ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB04PY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALE = ONE + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'Precision' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) + SMLNUM = SMLNUM*DBLE( M*N ) / EPS + BIGNUM = ONE / SMLNUM +C + SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ), + $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) ) +C + SGN = ISGN +C + IF( NOTRNA .AND. NOTRNB ) THEN +C +C Solve A*X*B + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-left corner column by column by +C +C A(K,K)*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C M +C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L) + +C J=K+1 +C M L-1 +C SUM { A(K,J) * SUM [X(J,I)*B(I,L)] }. +C J=K I=1 +C +C Start column loop (index = L) +C L1 (L2) : column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 60 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 60 + L1 = L + IF( L.EQ.N ) THEN + L2 = L + ELSE + IF( B( L+1, L ).NE.ZERO ) THEN + L2 = L + 1 + ELSE + L2 = L + END IF + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = M +C + DO 50 K = M, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 50 + K2 = K + IF( K.EQ.1 ) THEN + K1 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + ELSE + K1 = K + END IF + KNEXT = K1 - 1 + END IF +C + MNK1 = MIN( K1+1, M ) + MNK2 = MIN( K2+1, M ) + P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), + $ 1 ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 10 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 10 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 20 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 20 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 30 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 30 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) + P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) +C + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L2, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .FALSE., .FALSE., ISGN, 2, 2, + $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC, + $ 2, SCALOC, X, 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 40 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 40 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 50 CONTINUE +C + 60 CONTINUE +C + ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN +C +C Solve A'*X*B + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C upper-left corner column by column by +C +C A(K,K)'*X(K,L)*B(L,L) + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C K-1 +C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L) + +C J=1 +C K L-1 +C SUM A(J,K)' * { SUM [X(J,I)*B(I,L)] }. +C J=1 I=1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = 1 +C + DO 120 L = 1, N + IF( L.LT.LNEXT ) + $ GO TO 120 + L1 = L + IF( L.EQ.N ) THEN + L2 = L + ELSE + IF( B( L+1, L ).NE.ZERO ) THEN + L2 = L + 1 + ELSE + L2 = L + END IF + LNEXT = L2 + 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = 1 +C + DO 110 K = 1, M + IF( K.LT.KNEXT ) + $ GO TO 110 + K1 = K + IF( K.EQ.M ) THEN + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K2 = K + 1 + ELSE + K2 = K + END IF + KNEXT = K2 + 1 + END IF +C + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + DWORK( K1 ) = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1), + $ 1 ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 70 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 70 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L1), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 80 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 80 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 90 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 90 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + CALL DSCAL( K1, SCALOC, DWORK( M+1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) +C + DWORK( K2 ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L1), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L2, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L2, L1 ) ) +C + DWORK( K1+M ) = DDOT( L1-1, C( K1, 1 ), LDC, + $ B( 1, L2 ), 1 ) + DWORK( K2+M ) = DDOT( L1-1, C( K2, 1 ), LDC, + $ B( 1, L2 ), 1 ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L1, L2 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L1, L2 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 100 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 100 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + CALL DSCAL( K2, SCALOC, DWORK( M+1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 110 CONTINUE +C + 120 CONTINUE +C + ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN +C +C Solve A'*X*B' + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C top-right corner column by column by +C +C A(K,K)'*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C K-1 +C R(K,L) = { SUM [A(J,K)'*X(J,L)] } * B(L,L)' + +C J=1 +C K N +C SUM A(J,K)' * { SUM [X(J,I)*B(L,I)'] }. +C J=1 I=L+1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = N +C + DO 180 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 180 + L2 = L + IF( L.EQ.1 ) THEN + L1 = L + ELSE + IF( B( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + ELSE + L1 = L + END IF + LNEXT = L1 - 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = 1 +C + DO 170 K = 1, M + IF( K.LT.KNEXT ) + $ GO TO 170 + K1 = K + IF( K.EQ.M ) THEN + K2 = K + ELSE + IF( A( K+1, K ).NE.ZERO ) THEN + K2 = K + 1 + ELSE + K2 = K + END IF + KNEXT = K2 + 1 + END IF +C + MNL1 = MIN( L1+1, N ) + MNL2 = MIN( L2+1, N ) + P11 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 ) + DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 130 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 130 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, + $ B( L1, MNL1 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .TRUE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 140 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 140 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( K1, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 150 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 150 CONTINUE +C + CALL DSCAL( K1, SCALOC, DWORK, 1 ) + CALL DSCAL( K1, SCALOC, DWORK(M+1), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 ) + P12 = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 ) + P22 = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 ) +C + DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK, 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK, 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( K2, A( 1, K1 ), 1, DWORK( M+1 ), 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( K2, A( 1, K2 ), 1, DWORK( M+1 ), 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 160 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 160 CONTINUE +C + CALL DSCAL( K2, SCALOC, DWORK, 1 ) + CALL DSCAL( K2, SCALOC, DWORK(M+1), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 170 CONTINUE +C + 180 CONTINUE +C + ELSE +C +C Solve A*X*B' + ISGN*X = scale*C. +C +C The (K,L)th block of X is determined starting from +C bottom-right corner column by column by +C +C A(K,K)*X(K,L)*B(L,L)' + ISGN*X(K,L) = C(K,L) - R(K,L) +C +C where +C M +C R(K,L) = { SUM [A(K,J)*X(J,L)] } * B(L,L)' + +C J=K+1 +C M N +C SUM { A(K,J) * SUM [X(J,I)*B(L,I)'] }. +C J=K I=L+1 +C +C Start column loop (index = L) +C L1 (L2): column index of the first (last) row of X(K,L). +C + LNEXT = N +C + DO 240 L = N, 1, -1 + IF( L.GT.LNEXT ) + $ GO TO 240 + L2 = L + IF( L.EQ.1 ) THEN + L1 = L + ELSE + IF( B( L, L-1 ).NE.ZERO ) THEN + L1 = L - 1 + ELSE + L1 = L + END IF + LNEXT = L1 - 1 + END IF +C +C Start row loop (index = K) +C K1 (K2): row index of the first (last) row of X(K,L). +C + KNEXT = M +C + DO 230 K = M, 1, -1 + IF( K.GT.KNEXT ) + $ GO TO 230 + K2 = K + IF( K.EQ.1 ) THEN + K1 = K + ELSE + IF( A( K, K-1 ).NE.ZERO ) THEN + K1 = K - 1 + ELSE + K1 = K + END IF + KNEXT = K1 - 1 + END IF +C + MNK1 = MIN( K1+1, M ) + MNK2 = MIN( K2+1, M ) + MNL1 = MIN( L1+1, N ) + MNL2 = MIN( L2+1, N ) + P11 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L1 ), 1 ) + DWORK( K1 ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) +C + IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN +C + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) + SCALOC = ONE +C + A11 = A( K1, K1 )*B( L1, L1 ) + SGN + DA11 = ABS( A11 ) + IF( DA11.LE.SMIN ) THEN + A11 = SMIN + DA11 = SMIN + INFO = 1 + END IF + DB = ABS( VEC( 1, 1 ) ) + IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN + IF( DB.GT.BIGNUM*DA11 ) + $ SCALOC = ONE / DB + END IF + X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 190 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 190 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) +C + ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + DWORK( K2 ) = DDOT( N-L1, C( K2, MNL1 ), LDC, + $ B( L1, MNL1 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, B( L1, L1 ), + $ A( K1, K1 ), LDA, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 200 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 200 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K2, L1 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN +C + P12 = DDOT( M-K1, A( K1, MNK1 ), LDA, C( MNK1, L2 ), + $ 1 ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 1 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + CALL DLALN2( .FALSE., 2, 1, SMIN, A( K1, K1 ), + $ B( L1, L1 ), LDB, ONE, ONE, VEC, 2, -SGN, + $ ZERO, X, 2, SCALOC, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 210 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 210 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 2, 1 ) +C + ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN +C + P21 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L1 ), + $ 1 ) + P12 = DDOT( M-K2, A( K1, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) + P22 = DDOT( M-K2, A( K2, MNK2 ), LDA, C( MNK2, L2 ), + $ 1 ) +C + DWORK( K2 ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L1, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 1, 1 ) = C( K1, L1 ) - ( SUMR + P11*B( L1, L1 ) + + $ P12*B( L1, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1 ), + $ 1 ) + VEC( 2, 1 ) = C( K2, L1 ) - ( SUMR + P21*B( L1, L1 ) + + $ P22*B( L1, L2 ) ) +C + DWORK( K1+M ) = DDOT( N-L2, C( K1, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + DWORK( K2+M ) = DDOT( N-L2, C( K2, MNL2 ), LDC, + $ B( L2, MNL2 ), LDB ) + SUMR = DDOT( M-K1+1, A( K1, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 1, 2 ) = C( K1, L2 ) - ( SUMR + P11*B( L2, L1 ) + + $ P12*B( L2, L2 ) ) +C + SUMR = DDOT( M-K1+1, A( K2, K1 ), LDA, DWORK( K1+M ), + $ 1 ) + VEC( 2, 2 ) = C( K2, L2 ) - ( SUMR + P21*B( L2, L1 ) + + $ P22*B( L2, L2 ) ) +C + CALL SB04PX( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ), + $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X, + $ 2, XNORM, IERR ) + IF( IERR.NE.0 ) + $ INFO = 1 +C + IF( SCALOC.NE.ONE ) THEN +C + DO 220 J = 1, N + CALL DSCAL( M, SCALOC, C( 1, J ), 1 ) + 220 CONTINUE +C + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1 ), 1 ) + CALL DSCAL( M-K1+1, SCALOC, DWORK( K1+M ), 1 ) + SCALE = SCALE*SCALOC + END IF + C( K1, L1 ) = X( 1, 1 ) + C( K1, L2 ) = X( 1, 2 ) + C( K2, L1 ) = X( 2, 1 ) + C( K2, L2 ) = X( 2, 2 ) + END IF +C + 230 CONTINUE +C + 240 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04PY *** + END diff --git a/mex/sources/libslicot/SB04QD.f b/mex/sources/libslicot/SB04QD.f new file mode 100644 index 000000000..29ceae423 --- /dev/null +++ b/mex/sources/libslicot/SB04QD.f @@ -0,0 +1,376 @@ + SUBROUTINE SB04QD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C X + AXB = C, +C +C where A, B, C and X are general N-by-N, M-by-M, N-by-M and +C N-by-M matrices respectively. A Hessenberg-Schur method, which +C reduces A to upper Hessenberg form, H = U'AU, and B' to real +C Schur form, S = Z'B'Z (with U, Z orthogonal matrices), is used. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the coefficient matrix A of the equation. +C On exit, the leading N-by-N upper Hessenberg part of this +C array contains the matrix H, and the remainder of the +C leading N-by-N part, together with the elements 2,3,...,N +C of array DWORK, contain the orthogonal transformation +C matrix U (stored in factored form). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading M-by-M part of this array must +C contain the coefficient matrix B of the equation. +C On exit, the leading M-by-M part of this array contains +C the quasi-triangular Schur factor S of the matrix B'. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading N-by-M part of this array contains +C the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,M) +C The leading M-by-M part of this array contains the +C orthogonal matrix Z used to transform B' to real upper +C Schur form. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (4*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain +C the scalar factors of the elementary reflectors used to +C reduce A to upper Hessenberg form, as returned by LAPACK +C Library routine DGEHRD. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = MAX(1, 2*N*N + 9*N, 5*M, N + M). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, 1 <= i <= M, the QR algorithm failed to +C compute all the eigenvalues of B (see LAPACK Library +C routine DGEES); +C > M: if a singular matrix was encountered whilst solving +C for the (INFO-M)-th column of matrix X. +C +C METHOD +C +C The matrix A is transformed to upper Hessenberg form H = U'AU by +C the orthogonal transformation matrix U; matrix B' is transformed +C to real upper Schur form S = Z'B'Z using the orthogonal +C transformation matrix Z. The matrix C is also multiplied by the +C transformations, F = U'CZ, and the solution matrix Y of the +C transformed system +C +C Y + HYS' = F +C +C is computed by back substitution. Finally, the matrix Y is then +C multiplied by the orthogonal transformation matrices, X = UYZ', in +C order to obtain the solution matrix X to the original problem. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 3 3 2 2 +C The algorithm requires about (5/3) N + 10 M + 5 N M + 2.5 M N +C operations and is backward stable. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000, Aug. 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*) +C .. Local Scalars .. + INTEGER BL, CHUNK, I, IEIG, IFAIL, IHI, ILO, IND, ITAU, + $ JWORK, SDIM, WRKOPT +C .. Local Scalars .. + LOGICAL BLAS3, BLOCK +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY, + $ DORMHR, DSWAP, SB04QU, SB04QY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDWORK.LT.MAX( 1, 2*N*N + 9*N, 5*M, N + M ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + ILO = 1 + IHI = N + WRKOPT = 2*N*N + 9*N +C +C Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper +C triangular. That is, H = U' * A * U (store U in factored +C form) and S = Z' * B' * Z (save Z). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + DO 20 I = 2, M + CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB ) + 20 CONTINUE +C +C Workspace: need 5*M; +C prefer larger. +C + IEIG = M + 1 + JWORK = IEIG + M + CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB, + $ SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK), + $ LDWORK-JWORK+1, BWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + ITAU = 2 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Step 2 : Form F = ( U' * C ) * Z. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, MAX( INT( DWORK(JWORK) ), N*M )+JWORK-1 ) +C + CHUNK = ( LDWORK - JWORK + 1 ) / M + BLOCK = MIN( CHUNK, N ).GT.1 + BLAS3 = CHUNK.GE.N .AND. BLOCK +C + IF ( BLAS3 ) THEN + CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C, + $ LDC, Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 40 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, M, M, ONE, + $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) + CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) + 40 CONTINUE +C + ELSE +C + DO 60 I = 1, N + CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 60 CONTINUE +C + END IF +C +C Step 3 : Solve Y + H * Y * S' = F for Y. +C + IND = M + 80 CONTINUE +C + IF ( IND.GT.1 ) THEN + IF ( B(IND,IND-1).EQ.ZERO ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N. +C + CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + IND = IND - 1 + ELSE +C +C Solve a special linear algebraic system of order 2*N. +C Workspace: 2*N*N + 9*N; +C + CALL SB04QU( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + IND = IND - 2 + END IF + GO TO 80 + ELSE IF ( IND.EQ.1 ) THEN +C +C Solve a special linear algebraic system of order N. +C Workspace: N*(N+1)/2 + 3*N; +C + CALL SB04QY( M, N, IND, A, LDA, B, LDB, C, LDC, + $ DWORK(JWORK), IWORK, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = INFO + M + RETURN + END IF + END IF +C +C Step 4 : Form C = ( U * Y ) * Z'. Use BLAS 3, if enough space. +C +C Workspace: need N + M; +C prefer N + M*NB. +C + CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ IFAIL ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C + IF ( BLAS3 ) THEN + CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC, + $ Z, LDZ, ZERO, DWORK(JWORK), N ) + CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 100 I = 1, N, CHUNK + BL = MIN( N-I+1, CHUNK ) + CALL DGEMM( 'NoTranspose', 'Transpose', BL, M, M, ONE, + $ C(I,1), LDC, Z, LDZ, ZERO, DWORK(JWORK), BL ) + CALL DLACPY( 'Full', BL, M, DWORK(JWORK), BL, C(I,1), LDC ) + 100 CONTINUE +C + ELSE +C + DO 120 I = 1, N + CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC, + $ ZERO, DWORK(JWORK), 1 ) + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + 120 CONTINUE + END IF +C + RETURN +C *** Last line of SB04QD *** + END diff --git a/mex/sources/libslicot/SB04QR.f b/mex/sources/libslicot/SB04QR.f new file mode 100644 index 000000000..77231d322 --- /dev/null +++ b/mex/sources/libslicot/SB04QR.f @@ -0,0 +1,224 @@ + SUBROUTINE SB04QR( M, D, IPR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a linear algebraic system of order M whose coefficient +C matrix has zeros below the third subdiagonal and zero elements on +C the third subdiagonal with even column indices. The matrix is +C stored compactly, row-wise. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the system. M >= 0, M even. +C Note that parameter M should have twice the value in the +C original problem (see SLICOT Library routine SB04QU). +C +C D (input/output) DOUBLE PRECISION array, dimension +C (M*M/2+4*M) +C On entry, the first M*M/2 + 3*M elements of this array +C must contain the coefficient matrix, stored compactly, +C row-wise, and the next M elements must contain the right +C hand side of the linear system, as set by SLICOT Library +C routine SB04QU. +C On exit, the content of this array is updated, the last M +C elements containing the solution with components +C interchanged (see IPR). +C +C IPR (output) INTEGER array, dimension (2*M) +C The leading M elements contain information about the +C row interchanges performed for solving the system. +C Specifically, the i-th component of the solution is +C specified by IPR(i). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if a singular matrix was encountered. +C +C METHOD +C +C Gaussian elimination with partial pivoting is used. The rows of +C the matrix are not actually permuted, only their indices are +C interchanged in array IPR. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, M +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION D(*) +C .. Local Scalars .. + INTEGER I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1, + $ MPI2 + DOUBLE PRECISION D1, D2, D3, DMAX +C .. External Subroutines .. + EXTERNAL DAXPY +C .. Intrinsic Functions .. + INTRINSIC ABS, MOD +C .. Executable Statements .. +C + INFO = 0 + I2 = M*M/2 + 3*M + MPI = M + IPRM = I2 + M1 = M + I1 = 1 +C + DO 20 I = 1, M + MPI = MPI + 1 + IPRM = IPRM + 1 + IPR(MPI) = I1 + IPR(I) = IPRM + I1 = I1 + M1 + IF ( I.GE.4 .AND. MOD( I, 2 ).EQ.0 ) M1 = M1 - 2 + 20 CONTINUE +C + M1 = M - 1 + MPI1 = M + 1 +C +C Reduce to upper triangular form. +C + DO 80 I = 1, M1 + MPI = MPI1 + MPI1 = MPI1 + 1 + IPRM = IPR(MPI) + D1 = D(IPRM) + I1 = 3 + IF ( MOD( I, 2 ).EQ.0 ) I1 = 2 + IF ( I.EQ.M1 ) I1 = 1 + MPI2 = MPI + I1 + L = 0 + DMAX = ABS( D1 ) +C + DO 40 J = MPI1, MPI2 + D2 = D(IPR(J)) + D3 = ABS( D2 ) + IF ( D3.GT.DMAX ) THEN + DMAX = D3 + D1 = D2 + L = J - MPI + END IF + 40 CONTINUE +C +C Check singularity. +C + IF ( DMAX.EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C + IF ( L.GT.0 ) THEN +C +C Permute the row indices. +C + K = IPRM + J = MPI + L + IPRM = IPR(J) + IPR(J) = K + IPR(MPI) = IPRM + K = IPR(I) + I2 = I + L + IPR(I) = IPR(I2) + IPR(I2) = K + END IF + IPRM = IPRM + 1 +C +C Annihilate the subdiagonal elements of the matrix. +C + I2 = I + D3 = D(IPR(I)) +C + DO 60 J = MPI1, MPI2 + I2 = I2 + 1 + IPRM1 = IPR(J) + DMAX = -D(IPRM1)/D1 + D(IPR(I2)) = D(IPR(I2)) + DMAX*D3 + CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 ) + IPR(J) = IPR(J) + 1 + 60 CONTINUE +C + 80 CONTINUE +C + MPI = M + M + IPRM = IPR(MPI) +C +C Check singularity. +C + IF ( D(IPRM).EQ.ZERO ) THEN + INFO = 1 + RETURN + END IF +C +C Back substitution. +C + D(IPR(M)) = D(IPR(M))/D(IPRM) +C + DO 120 I = M1, 1, -1 + MPI = MPI - 1 + IPRM = IPR(MPI) + IPRM1 = IPRM + DMAX = ZERO +C + DO 100 K = I+1, M + IPRM1 = IPRM1 + 1 + DMAX = DMAX + D(IPR(K))*D(IPRM1) + 100 CONTINUE +C + D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM) + 120 CONTINUE +C + RETURN +C *** Last line of SB04QR *** + END diff --git a/mex/sources/libslicot/SB04QU.f b/mex/sources/libslicot/SB04QU.f new file mode 100644 index 000000000..2a53f1e3b --- /dev/null +++ b/mex/sources/libslicot/SB04QU.f @@ -0,0 +1,218 @@ + SUBROUTINE SB04QU( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order 2*M +C whose coefficient matrix has zeros below the third subdiagonal, +C and zero elements on the third subdiagonal with even column +C indices. Such systems appear when solving discrete-time Sylvester +C equations using the Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C IND and IND - 1 specify the indices of the columns in C +C to be computed. IND > 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with columns IND-1 and IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (2*M*M+8*M) +C +C IPR INTEGER array, dimension (4*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order 2*M, whose coefficient +C matrix has zeros below the third subdiagonal and zero elements on +C the third subdiagonal with even column indices, is constructed and +C solved. The coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, IND1, J, K, K1, K2, M2 + DOUBLE PRECISION TEMP +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DTRMV, SB04QR +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + IND1 = IND - 1 +C + IF ( IND.LT.N ) THEN + DUM(1) = ZERO + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 10 I = IND + 1, N + CALL DAXPY ( M, B(IND1,I), C(1,I), 1, D, 1 ) + 10 CONTINUE +C + DO 20 I = 2, M + C(I,IND1) = C(I,IND1) - A(I,I-1)*D(I-1) + 20 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 30 I = 1, M + C(I,IND1) = C(I,IND1) - D(I) + 30 CONTINUE +C + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 40 I = IND + 1, N + CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) + 40 CONTINUE +C + DO 50 I = 2, M + C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) + 50 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 60 I = 1, M + C(I,IND) = C(I,IND) - D(I) + 60 CONTINUE + END IF +C +C Construct the linear algebraic system of order 2*M. +C + K1 = -1 + M2 = 2*M + I2 = M2*(M + 3) + K = M2 +C + DO 80 I = 1, M +C + DO 70 J = MAX( 1, I - 1 ), M + K1 = K1 + 2 + K2 = K1 + K + TEMP = A(I,J) + D(K1) = TEMP * B(IND1,IND1) + D(K1+1) = TEMP * B(IND1,IND) + D(K2) = TEMP * B(IND,IND1) + D(K2+1) = TEMP * B(IND,IND) + IF ( I.EQ.J ) THEN + D(K1) = D(K1) + ONE + D(K2+1) = D(K2+1) + ONE + END IF + 70 CONTINUE +C + K1 = K2 + IF ( I.GT.1 ) K = K - 2 +C +C Store the right hand side. +C + I2 = I2 + 2 + D(I2) = C(I,IND) + D(I2-1) = C(I,IND1) + 80 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04QR( M2, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE + I2 = 0 +C + DO 90 I = 1, M + I2 = I2 + 2 + C(I,IND1) = D(IPR(I2-1)) + C(I,IND) = D(IPR(I2)) + 90 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04QU *** + END diff --git a/mex/sources/libslicot/SB04QY.f b/mex/sources/libslicot/SB04QY.f new file mode 100644 index 000000000..f351a2f4e --- /dev/null +++ b/mex/sources/libslicot/SB04QY.f @@ -0,0 +1,185 @@ + SUBROUTINE SB04QY( N, M, IND, A, LDA, B, LDB, C, LDC, D, IPR, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct and solve a linear algebraic system of order M whose +C coefficient matrix is in upper Hessenberg form. Such systems +C appear when solving discrete-time Sylvester equations using the +C Hessenberg-Schur method. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix B. N >= 0. +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C IND (input) INTEGER +C The index of the column in C to be computed. IND >= 1. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain an +C upper Hessenberg matrix. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,N) +C The leading N-by-N part of this array must contain a +C matrix in real Schur form. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading M-by-N part of this array must +C contain the coefficient matrix C of the equation. +C On exit, the leading M-by-N part of this array contains +C the matrix C with column IND updated. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M). +C +C Workspace +C +C D DOUBLE PRECISION array, dimension (M*(M+1)/2+2*M) +C +C IPR INTEGER array, dimension (2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C > 0: if INFO = IND, a singular matrix was encountered. +C +C METHOD +C +C A special linear algebraic system of order M, with coefficient +C matrix in upper Hessenberg form is constructed and solved. The +C coefficient matrix is stored compactly, row-wise. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, IND, LDA, LDB, LDC, M, N +C .. Array Arguments .. + INTEGER IPR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(*) +C .. Local Scalars .. + INTEGER I, I2, J, K, K1, K2, M1 +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, DTRMV, SB04MW +C .. Executable Statements .. +C + IF ( IND.LT.N ) THEN + DUM(1) = ZERO + CALL DCOPY ( M, DUM, 0, D, 1 ) + DO 10 I = IND + 1, N + CALL DAXPY ( M, B(IND,I), C(1,I), 1, D, 1 ) + 10 CONTINUE + DO 20 I = 2, M + C(I,IND) = C(I,IND) - A(I,I-1)*D(I-1) + 20 CONTINUE + CALL DTRMV ( 'Upper', 'No Transpose', 'Non Unit', M, A, LDA, + $ D, 1 ) + DO 30 I = 1, M + C(I,IND) = C(I,IND) - D(I) + 30 CONTINUE + END IF +C + M1 = M + 1 + I2 = ( M*M1 )/2 + M1 + K2 = 1 + K = M +C +C Construct the linear algebraic system of order M. +C + DO 40 I = 1, M + J = M1 - K + CALL DCOPY ( K, A(I,J), LDA, D(K2), 1 ) + CALL DSCAL ( K, B(IND,IND), D(K2), 1 ) + K1 = K2 + K2 = K2 + K + IF ( I.GT.1 ) THEN + K1 = K1 + 1 + K = K - 1 + END IF + D(K1) = D(K1) + ONE +C +C Store the right hand side. +C + D(I2) = C(I,IND) + I2 = I2 + 1 + 40 CONTINUE +C +C Solve the linear algebraic system and store the solution in C. +C + CALL SB04MW( M, D, IPR, INFO ) +C + IF ( INFO.NE.0 ) THEN + INFO = IND + ELSE +C + DO 50 I = 1, M + C(I,IND) = D(IPR(I)) + 50 CONTINUE +C + END IF +C + RETURN +C *** Last line of SB04QY *** + END diff --git a/mex/sources/libslicot/SB04RD.f b/mex/sources/libslicot/SB04RD.f new file mode 100644 index 000000000..6fd6feaec --- /dev/null +++ b/mex/sources/libslicot/SB04RD.f @@ -0,0 +1,406 @@ + SUBROUTINE SB04RD( ABSCHU, ULA, ULB, N, M, A, LDA, B, LDB, C, + $ LDC, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the discrete-time Sylvester equation +C +C X + AXB = C, +C +C with at least one of the matrices A or B in Schur form and the +C other in Hessenberg or Schur form (both either upper or lower); +C A, B, C and X are N-by-N, M-by-M, N-by-M, and N-by-M matrices, +C respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHU CHARACTER*1 +C Indicates whether A and/or B is/are in Schur or +C Hessenberg form as follows: +C = 'A': A is in Schur form, B is in Hessenberg form; +C = 'B': B is in Schur form, A is in Hessenberg form; +C = 'S': Both A and B are in Schur form. +C +C ULA CHARACTER*1 +C Indicates whether A is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': A is in upper Hessenberg form if ABSCHU = 'B' and +C upper Schur form otherwise; +C = 'L': A is in lower Hessenberg form if ABSCHU = 'B' and +C lower Schur form otherwise. +C +C ULB CHARACTER*1 +C Indicates whether B is in upper or lower Schur form or +C upper or lower Hessenberg form as follows: +C = 'U': B is in upper Hessenberg form if ABSCHU = 'A' and +C upper Schur form otherwise; +C = 'L': B is in lower Hessenberg form if ABSCHU = 'A' and +C lower Schur form otherwise. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C coefficient matrix A of the equation. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading M-by-M part of this array must contain the +C coefficient matrix B of the equation. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,M). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,M) +C On entry, the leading N-by-M part of this array must +C contain the coefficient matrix C of the equation. +C On exit, if INFO = 0, the leading N-by-M part of this +C array contains the solution matrix X of the problem. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity in +C the Sylvester equation. If the user sets TOL > 0, then the +C given value of TOL is used as a lower bound for the +C reciprocal condition number; a matrix whose estimated +C condition number is less than 1/TOL is considered to be +C nonsingular. If the user sets TOL <= 0, then a default +C tolerance, defined by TOLDEF = EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*MAX(M,N)) +C This parameter is not referenced if ABSCHU = 'S', +C ULA = 'U', and ULB = 'U'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = 2*N, if ABSCHU = 'S', ULA = 'U', and ULB = 'U'; +C LDWORK = 2*MAX(M,N)*(4 + 2*MAX(M,N)), otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if a (numerically) singular matrix T was encountered +C during the computation of the solution matrix X. +C That is, the estimated reciprocal condition number +C of T is less than or equal to TOL. +C +C METHOD +C +C Matrices A and B are assumed to be in (upper or lower) Hessenberg +C or Schur form (with at least one of them in Schur form). The +C solution matrix X is then computed by rows or columns via the back +C substitution scheme proposed by Golub, Nash and Van Loan (see +C [1]), which involves the solution of triangular systems of +C equations that are constructed recursively and which may be nearly +C singular if A and -B have almost reciprocal eigenvalues. If near +C singularity is detected, then the routine returns with the Error +C Indicator (INFO) set to 1. +C +C REFERENCES +C +C [1] Golub, G.H., Nash, S. and Van Loan, C.F. +C A Hessenberg-Schur method for the problem AX + XB = C. +C IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979. +C +C [2] Sima, V. +C Algorithms for Linear-quadratic Optimization. +C Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C 2 2 +C The algorithm requires approximately 5M N + 0.5MN operations in +C 2 2 +C the worst case and 2.5M N + 0.5MN operations in the best case +C (where M is the order of the matrix in Hessenberg form and N is +C the order of the matrix in Schur form) and is mixed stable (see +C [1]). +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2000. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHU, ULA, ULB + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) +C .. Local Scalars .. + CHARACTER ABSCHR + LOGICAL LABSCB, LABSCS, LULA, LULB + INTEGER FWD, I, IBEG, IEND, INCR, IPINCR, ISTEP, JWORK, + $ LDW, MAXMN + DOUBLE PRECISION SCALE, TOL1 +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, SB04PY, SB04RV, SB04RW, SB04RX, SB04RY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + MAXMN = MAX( M, N ) + LABSCB = LSAME( ABSCHU, 'B' ) + LABSCS = LSAME( ABSCHU, 'S' ) + LULA = LSAME( ULA, 'U' ) + LULB = LSAME( ULB, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LABSCB .AND. .NOT.LABSCS .AND. + $ .NOT.LSAME( ABSCHU, 'A' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LULA .AND. .NOT.LSAME( ULA, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LULB .AND. .NOT.LSAME( ULB, 'L' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.2*N .OR. + $ ( LDWORK.LT.2*MAXMN*( 4 + 2*MAXMN ) .AND. + $ .NOT.( LABSCS .AND. LULA .AND. LULB ) ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB04RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAXMN.EQ.0 ) + $ RETURN +C + IF ( LABSCS .AND. LULA .AND. LULB ) THEN +C +C If both matrices are in a real Schur form, use SB04PY. +C + CALL SB04PY( 'NoTranspose', 'NoTranspose', 1, N, M, A, LDA, + $ B, LDB, C, LDC, SCALE, DWORK, INFO ) + IF ( SCALE.NE.ONE ) + $ INFO = 1 + RETURN + END IF +C + LDW = 2*MAXMN + JWORK = LDW*LDW + 3*LDW + 1 + TOL1 = TOL + IF ( TOL1.LE.ZERO ) + $ TOL1 = DLAMCH( 'Epsilon' ) +C +C Choose the smallest of both matrices as the one in Hessenberg +C form when possible. +C + ABSCHR = ABSCHU + IF ( LABSCS ) THEN + IF ( N.GT.M ) THEN + ABSCHR = 'A' + ELSE + ABSCHR = 'B' + END IF + END IF + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C B is in Schur form: recursion on the columns of B. +C + IF ( LULB ) THEN +C +C B is upper: forward recursion. +C + IBEG = 1 + IEND = M + FWD = 1 + INCR = 0 + ELSE +C +C B is lower: backward recursion. +C + IBEG = M + IEND = 1 + FWD = -1 + INCR = -1 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 20 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( B(I+FWD,I).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04RW( ABSCHR, ULB, N, M, C, LDC, I, B, LDB, + $ A, LDA, DWORK(JWORK), DWORK ) + CALL SB04RY( 'R', ULA, N, A, LDA, B(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 1, C(1,I), 1 ) + ELSE + IPINCR = I + INCR + CALL SB04RV( ABSCHR, ULB, N, M, C, LDC, IPINCR, B, LDB, + $ A, LDA, DWORK(JWORK), DWORK ) + CALL SB04RX( 'R', ULA, N, A, LDA, B(IPINCR,IPINCR), + $ B(IPINCR+1,IPINCR), B(IPINCR,IPINCR+1), + $ B(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( N, DWORK(JWORK), 2, C(1,IPINCR), 1 ) + CALL DCOPY( N, DWORK(JWORK+1), 2, C(1,IPINCR+1), 1 ) + END IF + I = I + FWD*ISTEP + GO TO 20 + END IF +C END WHILE 20 + ELSE +C +C A is in Schur form: recursion on the rows of A. +C + IF ( LULA ) THEN +C +C A is upper: backward recursion. +C + IBEG = N + IEND = 1 + FWD = -1 + INCR = -1 + ELSE +C +C A is lower: forward recursion. +C + IBEG = 1 + IEND = N + FWD = 1 + INCR = 0 + END IF + I = IBEG +C WHILE ( ( IEND - I ) * FWD .GE. 0 ) DO + 40 IF ( ( IEND - I )*FWD.GE.0 ) THEN +C +C Test for 1-by-1 or 2-by-2 diagonal block in the Schur +C form. +C + IF ( I.EQ.IEND ) THEN + ISTEP = 1 + ELSE + IF ( A(I,I+FWD).EQ.ZERO ) THEN + ISTEP = 1 + ELSE + ISTEP = 2 + END IF + END IF +C + IF ( ISTEP.EQ.1 ) THEN + CALL SB04RW( ABSCHR, ULA, N, M, C, LDC, I, A, LDA, + $ B, LDB, DWORK(JWORK), DWORK ) + CALL SB04RY( 'C', ULB, M, B, LDB, A(I,I), DWORK(JWORK), + $ TOL1, IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC ) + ELSE + IPINCR = I + INCR + CALL SB04RV( ABSCHR, ULA, N, M, C, LDC, IPINCR, A, LDA, + $ B, LDB, DWORK(JWORK), DWORK ) + CALL SB04RX( 'C', ULB, M, B, LDB, A(IPINCR,IPINCR), + $ A(IPINCR+1,IPINCR), A(IPINCR,IPINCR+1), + $ A(IPINCR+1,IPINCR+1), DWORK(JWORK), TOL1, + $ IWORK, DWORK, LDW, INFO ) + IF ( INFO.EQ.1 ) + $ RETURN + CALL DCOPY( M, DWORK(JWORK), 2, C(IPINCR,1), LDC ) + CALL DCOPY( M, DWORK(JWORK+1), 2, C(IPINCR+1,1), LDC ) + END IF + I = I + FWD*ISTEP + GO TO 40 + END IF +C END WHILE 40 + END IF +C + RETURN +C *** Last line of SB04RD *** + END diff --git a/mex/sources/libslicot/SB04RV.f b/mex/sources/libslicot/SB04RV.f new file mode 100644 index 000000000..a385fb8ae --- /dev/null +++ b/mex/sources/libslicot/SB04RV.f @@ -0,0 +1,198 @@ + SUBROUTINE SB04RV( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, + $ LDBA, D, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the right-hand sides D for a system of equations in +C quasi-Hessenberg form solved via SB04RX (case with 2 right-hand +C sides). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation X + AXB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the first column/row of C to be used in +C the construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C, the matrix not contained in AB. +C +C LDBA INTEGER +C The leading dimension of array BA. +C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading 2*N or 2*M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side stored as a matrix with two rows. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C where LDWORK is equal to 2*N or 2*M (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDBA, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the 2 columns of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D(1), 2 ) + CALL DCOPY( N, C(1,INDX+1), 1, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, + $ ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX+1), + $ 1, ZERO, DWORK(N+1), 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, + $ ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.LT.M-1 ) THEN + CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, M-INDX-1, ONE, C(1,INDX+2), LDC, + $ AB(INDX+2,INDX+1), 1, ZERO, DWORK(N+1), 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK(N+1), 1, + $ ONE, D(2), 2 ) + END IF + END IF + ELSE +C +C Construct the 2 rows of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D(1), 2 ) + CALL DCOPY( M, C(INDX+1,1), LDC, D(2), 2 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N-1 ) THEN + CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, + $ AB(INDX,INDX+2), LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', N-INDX-1, M, ONE, C(INDX+2,1), LDC, + $ AB(INDX+1,INDX+2), LDAB, ZERO, DWORK(M+1), + $ 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, + $ ONE, D(2), 2 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), + $ LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX+1,1), + $ LDAB, ZERO, DWORK(M+1), 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, + $ D(1), 2 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK(M+1), 1, + $ ONE, D(2), 2 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04RV *** + END diff --git a/mex/sources/libslicot/SB04RW.f b/mex/sources/libslicot/SB04RW.f new file mode 100644 index 000000000..9dc815c67 --- /dev/null +++ b/mex/sources/libslicot/SB04RW.f @@ -0,0 +1,178 @@ + SUBROUTINE SB04RW( ABSCHR, UL, N, M, C, LDC, INDX, AB, LDAB, BA, + $ LDBA, D, DWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the right-hand side D for a system of equations in +C Hessenberg form solved via SB04RY (case with 1 right-hand side). +C +C ARGUMENTS +C +C Mode Parameters +C +C ABSCHR CHARACTER*1 +C Indicates whether AB contains A or B, as follows: +C = 'A': AB contains A; +C = 'B': AB contains B. +C +C UL CHARACTER*1 +C Indicates whether AB is upper or lower Hessenberg matrix, +C as follows: +C = 'U': AB is upper Hessenberg; +C = 'L': AB is lower Hessenberg. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The order of the matrix B. M >= 0. +C +C C (input) DOUBLE PRECISION array, dimension (LDC,M) +C The leading N-by-M part of this array must contain both +C the not yet modified part of the coefficient matrix C of +C the Sylvester equation X + AXB = C, and both the currently +C computed part of the solution of the Sylvester equation. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,N). +C +C INDX (input) INTEGER +C The position of the column/row of C to be used in the +C construction of the right-hand side D. +C +C AB (input) DOUBLE PRECISION array, dimension (LDAB,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C. +C +C LDAB INTEGER +C The leading dimension of array AB. +C LDAB >= MAX(1,N) or LDAB >= MAX(1,M) (depending on +C ABSCHR = 'A' or ABSCHR = 'B', respectively). +C +C BA (input) DOUBLE PRECISION array, dimension (LDBA,*) +C The leading N-by-N or M-by-M part of this array must +C contain either A or B of the Sylvester equation +C X + AXB = C, the matrix not contained in AB. +C +C LDBA INTEGER +C The leading dimension of array BA. +C LDBA >= MAX(1,N) or LDBA >= MAX(1,M) (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively). +C +C D (output) DOUBLE PRECISION array, dimension (*) +C The leading N or M part of this array (depending on +C ABSCHR = 'B' or ABSCHR = 'A', respectively) contains the +C right-hand side. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C where LDWORK is equal to N or M (depending on ABSCHR = 'B' +C or ABSCHR = 'A', respectively). +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ABSCHR, UL + INTEGER INDX, LDAB, LDBA, LDC, M, N +C .. Array Arguments .. + DOUBLE PRECISION AB(LDAB,*), BA(LDBA,*), C(LDC,*), D(*), DWORK(*) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMV +C .. Executable Statements .. +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + IF ( LSAME( ABSCHR, 'B' ) ) THEN +C +C Construct the column of the right-hand side. +C + CALL DCOPY( N, C(1,INDX), 1, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'N', N, INDX-1, ONE, C, LDC, AB(1,INDX), 1, + $ ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, + $ ONE, D, 1 ) + END IF + ELSE + IF ( INDX.LT.M ) THEN + CALL DGEMV( 'N', N, M-INDX, ONE, C(1,INDX+1), LDC, + $ AB(INDX+1,INDX), 1, ZERO, DWORK, 1 ) + CALL DGEMV( 'N', N, N, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + END IF + ELSE +C +C Construct the row of the right-hand side. +C + CALL DCOPY( M, C(INDX,1), LDC, D, 1 ) + IF ( LSAME( UL, 'U' ) ) THEN + IF ( INDX.LT.N ) THEN + CALL DGEMV( 'T', N-INDX, M, ONE, C(INDX+1,1), LDC, + $ AB(INDX,INDX+1), LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + ELSE + IF ( INDX.GT.1 ) THEN + CALL DGEMV( 'T', INDX-1, M, ONE, C, LDC, AB(INDX,1), + $ LDAB, ZERO, DWORK, 1 ) + CALL DGEMV( 'T', M, M, -ONE, BA, LDBA, DWORK, 1, ONE, D, + $ 1 ) + END IF + END IF + END IF +C + RETURN +C *** Last line of SB04RW *** + END diff --git a/mex/sources/libslicot/SB04RX.f b/mex/sources/libslicot/SB04RX.f new file mode 100644 index 000000000..e84bb188d --- /dev/null +++ b/mex/sources/libslicot/SB04RX.f @@ -0,0 +1,375 @@ + SUBROUTINE SB04RX( RC, UL, M, A, LDA, LAMBD1, LAMBD2, LAMBD3, + $ LAMBD4, D, TOL, IWORK, DWORK, LDDWOR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of equations in quasi-Hessenberg form +C (Hessenberg form plus two consecutive offdiagonals) with two +C right-hand sides. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether A is upper or lower Hessenberg matrix, +C as follows: +C = 'U': A is upper Hessenberg; +C = 'L': A is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBD1, (input) DOUBLE PRECISION +C LAMBD2, These variables must contain the 2-by-2 block to be +C LAMBD3, multiplied to the elements of A. +C LAMBD4 +C +C D (input/output) DOUBLE PRECISION array, dimension (2*M) +C On entry, this array must contain the two right-hand +C side vectors of the quasi-Hessenberg system, stored +C row-wise. +C On exit, if INFO = 0, this array contains the two solution +C vectors of the quasi-Hessenberg system, stored row-wise. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the quasi-Hessenberg matrix. +C A matrix whose estimated condition number is less +C than 1/TOL is considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,2*M+3) +C The leading 2*M-by-2*M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the quasi-Hessenberg matrix. The remaining 6*M elements +C are used as workspace for the computation of the +C reciprocal condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. +C LDDWOR >= MAX(1,2*M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the quasi-Hessenberg matrix is (numerically) +C singular. That is, its estimated reciprocal +C condition number is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M, LDA, and LDDWOR must be such that the value +C of the LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, 2*M ) ) +C +C These conditions are not checked by the routine. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBD1, LAMBD2, LAMBD3, LAMBD4, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, J2, M2, MJ, ML + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DLASET, DROT, DSCAL, DTRCON, + $ DTRSV +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN, MOD +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + M2 = M*2 + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + J2 = J*2 + ML = MIN( M, J + 1 ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2-1), 2 ) + CALL DSCAL( ML, LAMBD1, DWORK(1,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2-1), 2 ) + CALL DSCAL( ML, LAMBD3, DWORK(2,J2-1), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(1,J2), 2 ) + CALL DSCAL( ML, LAMBD2, DWORK(1,J2), 2 ) + CALL DCOPY( ML, A(1,J), 1, DWORK(2,J2), 2 ) + CALL DSCAL( ML, LAMBD4, DWORK(2,J2), 2 ) +C + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE + DWORK(J2,J2) = DWORK(J2,J2) + ONE + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(J+3,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+2,J), DWORK(J+3,J), C, S, R ) + DWORK(J+2,J) = R + DWORK(J+3,J) = ZERO + CALL DROT( MJ, DWORK(J+2,J+1), LDDWOR, + $ DWORK(J+3,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J+2,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J+1,J), DWORK(J+2,J), C, S, R ) + DWORK(J+1,J) = R + DWORK(J+2,J) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), LDDWOR, + $ DWORK(J+2,J+1), LDDWOR, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(MJ+1,MJ-2).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ-1), DWORK(MJ+1,MJ-2), C, + $ S, R ) + DWORK(MJ+1,MJ-1) = R + DWORK(MJ+1,MJ-2) = ZERO + CALL DROT( MJ, DWORK(1,MJ-1), 1, DWORK(1,MJ-2), 1, + $ C, S ) + CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ+1,MJ-1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ), DWORK(MJ+1,MJ-1), C, + $ S, R ) + DWORK(MJ+1,MJ) = R + DWORK(MJ+1,MJ-1) = ZERO + CALL DROT( MJ, DWORK(1,MJ), 1, DWORK(1,MJ-1), 1, C, + $ S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J2 = J*2 + J1 = MAX( J - 1, 1 ) + ML = MIN( M - J + 2, M ) + CALL DLASET( 'Full', M2, 2, ZERO, ZERO, DWORK(1,J2-1), + $ LDDWOR ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2-1), 2 ) + CALL DSCAL( ML, LAMBD1, DWORK(J1*2-1,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2-1), 2 ) + CALL DSCAL( ML, LAMBD3, DWORK(J1*2,J2-1), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2-1,J2), 2 ) + CALL DSCAL( ML, LAMBD2, DWORK(J1*2-1,J2), 2 ) + CALL DCOPY( ML, A(J1,J), 1, DWORK(J1*2,J2), 2 ) + CALL DSCAL( ML, LAMBD4, DWORK(J1*2,J2), 2 ) +C + DWORK(J2-1,J2-1) = DWORK(J2-1,J2-1) + ONE + DWORK(J2,J2) = DWORK(J2,J2) + ONE + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(MJ-2,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ-1,MJ+1), DWORK(MJ-2,MJ+1), C, + $ S, R ) + DWORK(MJ-1,MJ+1) = R + DWORK(MJ-2,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ-1,1), LDDWOR, + $ DWORK(MJ-2,1), LDDWOR, C, S ) + CALL DROT( 1, D(MJ-1), 1, D(MJ-2), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(MJ-1,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ,MJ+1), DWORK(MJ-1,MJ+1), C, + $ S, R ) + DWORK(MJ,MJ+1) = R + DWORK(MJ-1,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ,1), LDDWOR, DWORK(MJ-1,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ), 1, D(MJ-1), 1, C, S ) + END IF + END IF + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M2 - 1 + MJ = M2 - J + IF ( MOD(J,2).EQ.1 .AND. J.LT.M2-2 ) THEN + IF ( DWORK(J,J+3).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+2), DWORK(J,J+3), C, S, R ) + DWORK(J,J+2) = R + DWORK(J,J+3) = ZERO + CALL DROT( MJ, DWORK(J+1,J+2), 1, DWORK(J+1,J+3), + $ 1, C, S ) + CALL DROT( 1, D(J+2), 1, D(J+3), 1, C, S ) + END IF + END IF + IF ( J.LT.M2-1 ) THEN + IF ( DWORK(J,J+2).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J+1), DWORK(J,J+2), C, S, R ) + DWORK(J,J+1) = R + DWORK(J,J+2) = ZERO + CALL DROT( MJ, DWORK(J+1,J+1), 1, DWORK(J+1,J+2), + $ 1, C, S ) + CALL DROT( 1, D(J+1), 1, D(J+2), 1, C, S ) + END IF + END IF + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M2, DWORK, LDDWOR, RCOND, + $ DWORK(1,M2+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M2, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04RX *** + END diff --git a/mex/sources/libslicot/SB04RY.f b/mex/sources/libslicot/SB04RY.f new file mode 100644 index 000000000..2ea8fd91e --- /dev/null +++ b/mex/sources/libslicot/SB04RY.f @@ -0,0 +1,261 @@ + SUBROUTINE SB04RY( RC, UL, M, A, LDA, LAMBDA, D, TOL, IWORK, + $ DWORK, LDDWOR, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve a system of equations in Hessenberg form with one +C right-hand side. +C +C ARGUMENTS +C +C Mode Parameters +C +C RC CHARACTER*1 +C Indicates processing by columns or rows, as follows: +C = 'R': Row transformations are applied; +C = 'C': Column transformations are applied. +C +C UL CHARACTER*1 +C Indicates whether A is upper or lower Hessenberg matrix, +C as follows: +C = 'U': A is upper Hessenberg; +C = 'L': A is lower Hessenberg. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrix A. M >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain a +C matrix A in Hessenberg form. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C LAMBDA (input) DOUBLE PRECISION +C This variable must contain the value to be multiplied with +C the elements of A. +C +C D (input/output) DOUBLE PRECISION array, dimension (M) +C On entry, this array must contain the right-hand side +C vector of the Hessenberg system. +C On exit, if INFO = 0, this array contains the solution +C vector of the Hessenberg system. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the triangular factor R of the Hessenberg matrix. A matrix +C whose estimated condition number is less than 1/TOL is +C considered to be nonsingular. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDDWOR,M+3) +C The leading M-by-M part of this array is used for +C computing the triangular factor of the QR decomposition +C of the Hessenberg matrix. The remaining 3*M elements are +C used as workspace for the computation of the reciprocal +C condition estimate. +C +C LDDWOR INTEGER +C The leading dimension of array DWORK. LDDWOR >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 1: if the Hessenberg matrix is (numerically) singular. +C That is, its estimated reciprocal condition number +C is less than or equal to TOL. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C D. Sima, University of Bucharest, May 2000. +C +C REVISIONS +C +C - +C +C Note that RC, UL, M, LDA, and LDDWOR must be such that the value +C of the LOGICAL variable OK in the following statement is true. +C +C OK = ( ( UL.EQ.'U' ) .OR. ( UL.EQ.'u' ) .OR. +C ( UL.EQ.'L' ) .OR. ( UL.EQ.'l' ) ) +C .AND. +C ( ( RC.EQ.'R' ) .OR. ( RC.EQ.'r' ) .OR. +C ( RC.EQ.'C' ) .OR. ( RC.EQ.'c' ) ) +C .AND. +C ( M.GE.0 ) +C .AND. +C ( LDA.GE.MAX( 1, M ) ) +C .AND. +C ( LDDWOR.GE.MAX( 1, M ) ) +C +C These conditions are not checked by the routine. +C +C KEYWORDS +C +C Hessenberg form, orthogonal transformation, real Schur form, +C Sylvester equation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER RC, UL + INTEGER INFO, LDA, LDDWOR, M + DOUBLE PRECISION LAMBDA, TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), D(*), DWORK(LDDWOR,*) +C .. Local Scalars .. + CHARACTER TRANS + INTEGER J, J1, MJ + DOUBLE PRECISION C, R, RCOND, S +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLARTG, DROT, DSCAL, DTRCON, DTRSV +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C For speed, no tests on the input scalar arguments are made. +C Quick return if possible. +C + IF ( M.EQ.0 ) + $ RETURN +C + IF ( LSAME( UL, 'U' ) ) THEN +C + DO 20 J = 1, M + CALL DCOPY( MIN( J+1, M ), A(1,J), 1, DWORK(1,J), 1 ) + CALL DSCAL( MIN( J+1, M ), LAMBDA, DWORK(1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + ONE + 20 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is an upper Hessenberg matrix, row transformations. +C + DO 40 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J+1,J).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J+1,J), C, S, R ) + DWORK(J,J) = R + DWORK(J+1,J) = ZERO + CALL DROT( MJ, DWORK(J,J+1), LDDWOR, DWORK(J+1,J+1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 40 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is an upper Hessenberg matrix, column transformations. +C + DO 60 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ+1,MJ).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ+1,MJ), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ+1,MJ) = ZERO + CALL DROT( MJ, DWORK(1,MJ+1), 1, DWORK(1,MJ), 1, C, + $ S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 60 CONTINUE +C + END IF + ELSE +C + DO 80 J = 1, M + J1 = MAX( J - 1, 1 ) + CALL DCOPY( M-J1+1, A(J1,J), 1, DWORK(J1,J), 1 ) + CALL DSCAL( M-J1+1, LAMBDA, DWORK(J1,J), 1 ) + DWORK(J,J) = DWORK(J,J) + ONE + 80 CONTINUE +C + IF ( LSAME( RC, 'R' ) ) THEN + TRANS = 'N' +C +C A is a lower Hessenberg matrix, row transformations. +C + DO 100 J = 1, M - 1 + MJ = M - J + IF ( DWORK(MJ,MJ+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(MJ+1,MJ+1), DWORK(MJ,MJ+1), C, S, + $ R ) + DWORK(MJ+1,MJ+1) = R + DWORK(MJ,MJ+1) = ZERO + CALL DROT( MJ, DWORK(MJ+1,1), LDDWOR, DWORK(MJ,1), + $ LDDWOR, C, S ) + CALL DROT( 1, D(MJ+1), 1, D(MJ), 1, C, S ) + END IF + 100 CONTINUE +C + ELSE + TRANS = 'T' +C +C A is a lower Hessenberg matrix, column transformations. +C + DO 120 J = 1, M - 1 + MJ = M - J + IF ( DWORK(J,J+1).NE.ZERO ) THEN + CALL DLARTG( DWORK(J,J), DWORK(J,J+1), C, S, R ) + DWORK(J,J) = R + DWORK(J,J+1) = ZERO + CALL DROT( MJ, DWORK(J+1,J), 1, DWORK(J+1,J+1), 1, C, + $ S ) + CALL DROT( 1, D(J), 1, D(J+1), 1, C, S ) + END IF + 120 CONTINUE +C + END IF + END IF +C + CALL DTRCON( '1-norm', UL, 'Non-unit', M, DWORK, LDDWOR, RCOND, + $ DWORK(1,M+1), IWORK, INFO ) + IF ( RCOND.LE.TOL ) THEN + INFO = 1 + ELSE + CALL DTRSV( UL, TRANS, 'Non-unit', M, DWORK, LDDWOR, D, 1 ) + END IF +C + RETURN +C *** Last line of SB04RY *** + END diff --git a/mex/sources/libslicot/SB06ND.f b/mex/sources/libslicot/SB06ND.f new file mode 100644 index 000000000..3ea986376 --- /dev/null +++ b/mex/sources/libslicot/SB06ND.f @@ -0,0 +1,325 @@ + SUBROUTINE SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, F, + $ LDF, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the minimum norm feedback matrix F to perform +C "deadbeat control" on a (A,B)-pair of a state-space model (which +C must be preliminarily reduced to upper "staircase" form using +C SLICOT Library routine AB01OD) such that the matrix R = A + BFU' +C is nilpotent. +C (The transformation matrix U reduces R to upper Schur form with +C zero blocks on its diagonal (of dimension KSTAIR(i)) and +C therefore contains bases for the i-th controllable subspaces, +C where i = 1,...,KMAX). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The actual input dimension. M >= 0. +C +C KMAX (input) INTEGER +C The number of "stairs" in the staircase form as produced +C by SLICOT Library routine AB01OD. 0 <= KMAX <= N. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the transformed state-space matrix of the +C (A,B)-pair with triangular stairs, as produced by SLICOT +C Library routine AB01OD (with option STAGES = 'A'). +C On exit, the leading N-by-N part of this array contains +C the matrix U'AU + U'BF. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the transformed triangular input matrix of the +C (A,B)-pair as produced by SLICOT Library routine AB01OD +C (with option STAGES = 'A'). +C On exit, the leading N-by-M part of this array contains +C the matrix U'B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C KSTAIR (input) INTEGER array, dimension (KMAX) +C The leading KMAX elements of this array must contain the +C dimensions of each "stair" as produced by SLICOT Library +C routine AB01OD. +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,N) +C On entry, the leading N-by-N part of this array must +C contain either a transformation matrix (e.g. from a +C previous call to other SLICOT routine) or be initialised +C as the identity matrix. +C On exit, the leading N-by-N part of this array contains +C the product of the input matrix U and the state-space +C transformation matrix which reduces A + BFU' to real +C Schur form. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,N). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the +C deadbeat feedback matrix F. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Starting from the (A,B)-pair in "staircase form" with "triangular" +C stairs, dimensions KSTAIR(i+1) x KSTAIR(i), (described by the +C vector KSTAIR): +C +C | B | A * . . . * | +C | 1| 11 . . | +C | | A A . . | +C | | 21 22 . . | +C | | . . . | +C [ B | A ] = | | . . * | +C | | . . | +C | 0 | 0 | +C | | A A | +C | | r,r-1 rr | +C +C where the i-th diagonal block of A has dimension KSTAIR(i), for +C i = 1,2,...,r, the feedback matrix F is constructed recursively in +C r steps (where the number of "stairs" r is given by KMAX). In each +C step a unitary state-space transformation U and a part of F are +C updated in order to achieve the final form: +C +C | 0 A * . . . * | +C | 12 . . | +C | . . | +C | 0 A . . | +C | 23 . . | +C | . . | +C [ U'AU + U'BF ] = | . . * | . +C | . . | +C | | +C | A | +C | r-1,r| +C | | +C | 0 | +C +C +C REFERENCES +C +C [1] Van Dooren, P. +C Deadbeat control: a special inverse eigenvalue problem. +C BIT, 24, pp. 681-699, 1984. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O((N + M) * N**2) operations and is mixed +C numerical stable (see [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997. +C Supersedes Release 2.0 routine SB06BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C 1997, December 10; 2003, September 27. +C +C KEYWORDS +C +C Canonical form, deadbeat control, eigenvalue assignment, feedback +C control, orthogonal transformation, real Schur form, staircase +C form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, KMAX, LDA, LDB, LDF, LDU, M, N +C .. Array Arguments .. + INTEGER KSTAIR(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), U(LDU,*) +C .. Local Scalars .. + INTEGER J, J0, JCUR, JKCUR, JMKCUR, KCUR, KK, KMIN, + $ KSTEP, MKCUR, NCONT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLACPY, DLARFG, DLASET, DLATZM, + $ DTRSM, XERBLA +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( KMAX.LT.0 .OR. KMAX.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE + NCONT = 0 +C + DO 10 KK = 1, KMAX + NCONT = NCONT + KSTAIR(KK) + 10 CONTINUE +C + IF( NCONT.GT.N ) + $ INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB06ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + DO 120 KMIN = 1, KMAX + JCUR = NCONT + KSTEP = KMAX - KMIN +C +C Triangularize bottom part of A (if KSTEP > 0). +C + DO 40 KK = KMAX, KMAX - KSTEP + 1, -1 + KCUR = KSTAIR(KK) +C +C Construct Ukk and store in Fkk. +C + DO 20 J = 1, KCUR + JMKCUR = JCUR - KCUR + CALL DCOPY( KCUR, A(JCUR,JMKCUR), LDA, F(1,JCUR), 1 ) + CALL DLARFG( KCUR+1, A(JCUR,JCUR), F(1,JCUR), 1, + $ DWORK(JCUR) ) + CALL DLASET( 'Full', 1, KCUR, ZERO, ZERO, A(JCUR,JMKCUR), + $ LDA ) +C +C Backmultiply A and U with Ukk. +C + CALL DLATZM( 'Right', JCUR-1, KCUR+1, F(1,JCUR), 1, + $ DWORK(JCUR), A(1,JCUR), A(1,JMKCUR), LDA, + $ DWORK ) +C + CALL DLATZM( 'Right', N, KCUR+1, F(1,JCUR), 1, + $ DWORK(JCUR), U(1,JCUR), U(1,JMKCUR), LDU, + $ DWORK(N+1) ) + JCUR = JCUR - 1 + 20 CONTINUE +C + 40 CONTINUE +C +C Eliminate diagonal block Aii by feedback Fi. +C + KCUR = KSTAIR(KMIN) + J0 = JCUR - KCUR + 1 + MKCUR = M - KCUR + 1 +C +C Solve for Fi and add B x Fi to A. +C + CALL DLACPY( 'Full', KCUR, KCUR, A(J0,J0), LDA, F(MKCUR,J0), + $ LDF ) + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', KCUR, + $ KCUR, -ONE, B(J0,MKCUR), LDB, F(MKCUR,J0), LDF ) + IF ( J0.GT.1 ) + $ CALL DGEMM( 'No transpose', 'No transpose', J0-1, KCUR, + $ KCUR, ONE, B(1,MKCUR), LDB, F(MKCUR,J0), LDF, + $ ONE, A(1,J0), LDA ) + CALL DLASET( 'Full', KCUR, KCUR, ZERO, ZERO, A(J0,J0), LDA ) + CALL DLASET( 'Full', M-KCUR, KCUR, ZERO, ZERO, F(1,J0), LDF ) +C + IF ( KSTEP.NE.0 ) THEN + JKCUR = NCONT +C +C Premultiply A with Ukk. +C + DO 80 KK = KMAX, KMAX - KSTEP + 1, -1 + KCUR = KSTAIR(KK) + JCUR = JKCUR - KCUR +C + DO 60 J = 1, KCUR + CALL DLATZM( 'Left', KCUR+1, N-JCUR+1, F(1,JKCUR), 1, + $ DWORK(JKCUR), A(JKCUR,JCUR), + $ A(JCUR,JCUR), LDA, DWORK(N+1) ) + JCUR = JCUR - 1 + JKCUR = JKCUR - 1 + 60 CONTINUE +C + 80 CONTINUE +C +C Premultiply B with Ukk. +C + JCUR = JCUR + KCUR + JKCUR = JCUR + KCUR +C + DO 100 J = M, M - KCUR + 1, -1 + CALL DLATZM( 'Left', KCUR+1, M-J+1, F(1,JKCUR), 1, + $ DWORK(JKCUR), B(JKCUR,J), B(JCUR,J), LDB, + $ DWORK(N+1) ) + JCUR = JCUR - 1 + JKCUR = JKCUR - 1 + 100 CONTINUE +C + END IF + 120 CONTINUE +C + IF ( NCONT.NE.N ) + $ CALL DLASET( 'Full', M, N-NCONT, ZERO, ZERO, F(1,NCONT+1), + $ LDF ) +C + RETURN +C *** Last line of SB06ND *** + END diff --git a/mex/sources/libslicot/SB08CD.f b/mex/sources/libslicot/SB08CD.f new file mode 100644 index 000000000..ed703beb5 --- /dev/null +++ b/mex/sources/libslicot/SB08CD.f @@ -0,0 +1,355 @@ + SUBROUTINE SB08CD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct, for a given system G = (A,B,C,D), an output +C injection matrix H, an orthogonal transformation matrix Z, and a +C gain matrix V, such that the systems +C +C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), V*C*Z, V*D) +C and +C R = (Z'*(A+H*C)*Z, Z'*H, V*C*Z, V) +C +C provide a stable left coprime factorization of G in the form +C -1 +C G = R * Q, +C +C where G, Q and R are the corresponding transfer-function matrices +C and the denominator R is co-inner, that is, R(s)*R'(-s) = I in +C the continuous-time case, or R(z)*R'(1/z) = I in the discrete-time +C case. The Z matrix is not explicitly computed. +C +C Note: G must have no observable poles on the imaginary axis +C for a continuous-time system, or on the unit circle for a +C discrete-time system. If the given state-space representation +C is not detectable, the undetectable part of the original +C system is automatically deflated and the order of the systems +C Q and R is accordingly reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrices B +C and BR, and the number of columns of the matrix C. +C N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B and D. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows +C of the matrices C, D and DR, and the number of columns +C of the matrices BR and DR. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. The matrix A must not +C have observable eigenvalues on the imaginary axis, if +C DICO = 'C', or on the unit circle, if DICO = 'D'. +C On exit, the leading NQ-by-NQ part of this array contains +C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the +C state dynamics matrix of the numerator factor Q, in a +C real Schur form. The leading NR-by-NR part of this matrix +C represents the state dynamics matrix of a minimal +C realization of the denominator factor R. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix. +C On exit, the leading NQ-by-M part of this array contains +C the leading NQ-by-M part of the matrix Z'*(B+H*D), the +C input/state matrix of the numerator factor Q. +C The remaining part of this array is needed as workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-NQ part of this array contains +C the leading P-by-NQ part of the matrix V*C*Z, the +C state/output matrix of the numerator factor Q. +C The first NR columns of this array represent the +C state/output matrix of a minimal realization of the +C denominator factor R. +C The remaining part of this array is needed as workspace. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P), if N > 0. +C LDC >= 1, if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,MAX(M,P)) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix. +C On exit, the leading P-by-M part of this array contains +C the matrix V*D representing the input/output matrix +C of the numerator factor Q. +C The remaining part of this array is needed as workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C NQ (output) INTEGER +C The order of the resulting factors Q and R. +C Generally, NQ = N - NS, where NS is the number of +C unobservable eigenvalues outside the stability region. +C +C NR (output) INTEGER +C The order of the minimal realization of the factor R. +C Generally, NR is the number of observable eigenvalues +C of A outside the stability region (the number of modified +C eigenvalues). +C +C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) +C The leading NQ-by-P part of this array contains the +C leading NQ-by-P part of the output injection matrix +C Z'*H, which reflects the eigenvalues of A lying outside +C the stable region to values which are symmetric with +C respect to the imaginary axis (if DICO = 'C') or the unit +C circle (if DICO = 'D'). The first NR rows of this matrix +C form the input/state matrix of a minimal realization of +C the denominator factor R. +C +C LDBR INTEGER +C The leading dimension of array BR. LDBR >= MAX(1,N). +C +C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) +C The leading P-by-P part of this array contains the lower +C triangular matrix V representing the input/output matrix +C of the denominator factor R. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C C are considered zero (used for observability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(C), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(C) denotes +C the infinity-norm of C. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, P*N + MAX( N*(N+5),P*(P+2),4*P,4*M ) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(H) <= 10*NORM(A)/NORM(C) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + H*C)*Z +C along the diagonal; +C = 3: if DICO = 'C' and the matrix A has an observable +C eigenvalue on the imaginary axis, or DICO = 'D' and +C A has an observable eigenvalue on the unit circle. +C +C METHOD +C +C The subroutine uses the right coprime factorization algorithm with +C inner denominator of [1] applied to G'. +C +C REFERENCES +C +C [1] Varga A. +C A Schur method for computing coprime factorizations with +C inner denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine LCFID. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C May 2003, A. Varga, DLR Oberpfaffenhofen. +C Nov 2003, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, + $ LDWORK, M, N, NQ, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), + $ D(LDD,*), DR(LDDR,*), DWORK(*) +C .. Local Scalars .. + INTEGER I, KBR, KW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External subroutines .. + EXTERNAL AB07MD, DLASET, DSWAP, MA02AD, MA02BD, SB08DD, + $ TB01XD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.LSAME( DICO, 'C' ) .AND. + $ .NOT.LSAME( DICO, 'D' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) + $ THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN + INFO = -12 + ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, P*N + MAX( N*(N+5), P*(P+2), 4*P, + $ 4*M ) ) ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, P ).EQ.0 ) THEN + NQ = 0 + NR = 0 + DWORK(1) = ONE + CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) + RETURN + END IF +C +C Compute the dual system G' = (A',C',B',D'). +C + CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) +C +C Compute the right coprime factorization with inner +C denominator of G'. +C +C Workspace needed: P*N; +C Additional workspace: need MAX( N*(N+5), P*(P+2), 4*P, 4*M ); +C prefer larger. +C + KBR = 1 + KW = KBR + P*N + CALL SB08DD( DICO, N, P, M, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), + $ LDWORK-KW+1, IWARN, INFO ) + IF( INFO.EQ.0 ) THEN +C +C Determine the elements of the left coprime factorization from +C those of the computed right coprime factorization and make the +C state-matrix upper real Schur. +C + CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), + $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) +C + CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) + CALL MA02BD( 'Left', NQ, P, BR, LDBR ) +C + DO 10 I = 2, P + CALL DSWAP( I-1, DR(I,1), LDDR, DR(1,I), 1 ) + 10 CONTINUE +C + END IF +C + DWORK(1) = DWORK(KW) + DBLE( KW-1 ) +C + RETURN +C *** Last line of SB08CD *** + END diff --git a/mex/sources/libslicot/SB08DD.f b/mex/sources/libslicot/SB08DD.f new file mode 100644 index 000000000..e88c9028d --- /dev/null +++ b/mex/sources/libslicot/SB08DD.f @@ -0,0 +1,583 @@ + SUBROUTINE SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, LDWORK, + $ IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct, for a given system G = (A,B,C,D), a feedback matrix +C F, an orthogonal transformation matrix Z, and a gain matrix V, +C such that the systems +C +C Q = (Z'*(A+B*F)*Z, Z'*B*V, (C+D*F)*Z, D*V) +C and +C R = (Z'*(A+B*F)*Z, Z'*B*V, F*Z, V) +C +C provide a stable right coprime factorization of G in the form +C -1 +C G = Q * R , +C +C where G, Q and R are the corresponding transfer-function matrices +C and the denominator R is inner, that is, R'(-s)*R(s) = I in the +C continuous-time case, or R'(1/z)*R(z) = I in the discrete-time +C case. The Z matrix is not explicitly computed. +C +C Note: G must have no controllable poles on the imaginary axis +C for a continuous-time system, or on the unit circle for a +C discrete-time system. If the given state-space representation +C is not stabilizable, the unstabilizable part of the original +C system is automatically deflated and the order of the systems +C Q and R is accordingly reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrix B and +C the number of columns of the matrices C and CR. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B, D and DR and the number of rows of the +C matrices CR and DR. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows +C of the matrices C and D. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. The matrix A must not +C have controllable eigenvalues on the imaginary axis, if +C DICO = 'C', or on the unit circle, if DICO = 'D'. +C On exit, the leading NQ-by-NQ part of this array contains +C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the +C state dynamics matrix of the numerator factor Q, in a +C real Schur form. The trailing NR-by-NR part of this matrix +C represents the state dynamics matrix of a minimal +C realization of the denominator factor R. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix. +C On exit, the leading NQ-by-M part of this array contains +C the leading NQ-by-M part of the matrix Z'*B*V, the +C input/state matrix of the numerator factor Q. The last +C NR rows of this matrix form the input/state matrix of +C a minimal realization of the denominator factor R. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-NQ part of this array contains +C the leading P-by-NQ part of the matrix (C+D*F)*Z, +C the state/output matrix of the numerator factor Q. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix. +C On exit, the leading P-by-M part of this array contains +C the matrix D*V representing the input/output matrix +C of the numerator factor Q. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the resulting factors Q and R. +C Generally, NQ = N - NS, where NS is the number of +C uncontrollable eigenvalues outside the stability region. +C +C NR (output) INTEGER +C The order of the minimal realization of the factor R. +C Generally, NR is the number of controllable eigenvalues +C of A outside the stability region (the number of modified +C eigenvalues). +C +C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) +C The leading M-by-NQ part of this array contains the +C leading M-by-NQ part of the feedback matrix F*Z, which +C reflects the eigenvalues of A lying outside the stable +C region to values which are symmetric with respect to the +C imaginary axis (if DICO = 'C') or the unit circle (if +C DICO = 'D'). The last NR columns of this matrix form the +C state/output matrix of a minimal realization of the +C denominator factor R. +C +C LDCR INTEGER +C The leading dimension of array CR. LDCR >= MAX(1,M). +C +C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) +C The leading M-by-M part of this array contains the upper +C triangular matrix V of order M representing the +C input/output matrix of the denominator factor R. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,M). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(B), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(B) denotes +C the 1-norm of B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(F) <= 10*NORM(A)/NORM(B) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal; +C = 3: if DICO = 'C' and the matrix A has a controllable +C eigenvalue on the imaginary axis, or DICO = 'D' +C and A has a controllable eigenvalue on the unit +C circle. +C +C METHOD +C +C The subroutine is based on the factorization algorithm of [1]. +C +C REFERENCES +C +C [1] Varga A. +C A Schur method for computing coprime factorizations with inner +C denominators and applications in model reduction. +C Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine RCFID. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Feb. 1999, May 2003, A. Varga, DLR Oberpfaffenhofen. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TEN, ZERO + PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, + $ LDWORK, M, N, NQ, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), + $ D(LDD,*), DR(LDDR,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER I, IB, IB1, J, K, KFI, KV, KW, KWI, KWR, KZ, L, + $ L1, NB, NCUR, NFP, NLOW, NSUP + DOUBLE PRECISION ALPHA, BNORM, CS, PR, RMAX, SM, SN, TOLER, + $ WRKOPT, X, Y +C .. Local Arrays .. + DOUBLE PRECISION Z(4,4) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, + $ DTRMM, DTRMV, SB01FY, TB01LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ) ) THEN + INFO = -21 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08DD', -INFO ) + RETURN + END IF +C +C Set DR = I and quick return if possible. +C + NR = 0 + IF( MIN( M, P ).GT.0 ) + $ CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) + IF( MIN( N, M ).EQ.0 ) THEN + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Set F = 0 in the array CR. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) +C +C Compute the norm of B and set the default tolerance if necessary. +C + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + TOLER = TOL + IF( TOLER.LE.ZERO ) + $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) + IF( BNORM.LE.TOLER ) THEN + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Compute the bound for the numerical stability condition. +C + RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM +C +C Allocate working storage. +C + KZ = 1 + KWR = KZ + N*N + KWI = KWR + N + KW = KWI + N +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- Z'*A*Z and accumulate the +C transformations in Z. The separation of spectrum of A is +C performed such that the leading NFP-by-NFP submatrix of A +C corresponds to the "stable" eigenvalues which will be not +C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A +C corresponds to the "unstable" eigenvalues to be modified. +C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + IF( DISCR ) THEN + ALPHA = ONE + ELSE + ALPHA = ZERO + END IF + CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA, A, LDA, + $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Perform the pole assignment if there exist "unstable" eigenvalues. +C + NQ = N + IF( NFP.LT.N ) THEN + KV = 1 + KFI = KV + M*M + KW = KFI + 2*M +C +C Set the limits for the bottom diagonal block. +C + NLOW = NFP + 1 + NSUP = N +C +C WHILE (NLOW <= NSUP) DO + 10 IF( NLOW.LE.NSUP ) THEN +C +C Main loop for assigning one or two poles. +C +C Determine the dimension of the last block. +C + IB = 1 + IF( NLOW.LT.NSUP ) THEN + IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 + END IF + L = NSUP - IB + 1 +C +C Check the controllability of the last block. +C + IF( DLANGE( '1-norm', IB, M, B(L,1), LDB, DWORK(KW) ) + $ .LE.TOLER ) THEN +C +C Deflate the uncontrollable block and resume the main +C loop. +C + NSUP = NSUP - IB + ELSE +C +C Determine the M-by-IB feedback matrix FI which assigns +C the selected IB poles for the pair +C ( A(L:L+IB-1,L:L+IB-1), B(L:L+IB-1,1:M) ). +C +C Workspace needed: M*(M+2). +C + CALL SB01FY( DISCR, IB, M, A(L,L), LDA, B(L,1), LDB, + $ DWORK(KFI), M, DWORK(KV), M, INFO ) + IF( INFO.EQ.2 ) THEN + INFO = 3 + RETURN + END IF +C +C Check for possible numerical instability. +C + IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) + $ .GT.RMAX ) IWARN = IWARN + 1 +C +C Update the state matrix A <-- A + B*[0 FI]. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, + $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), + $ LDA ) +C +C Update the feedback matrix F <-- F + V*[0 FI] in CR. +C + IF( DISCR ) + $ CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', + $ M, IB, ONE, DR, LDDR, DWORK(KFI), M ) + K = KFI + DO 30 J = L, L + IB - 1 + DO 20 I = 1, M + CR(I,J) = CR(I,J) + DWORK(K) + K = K + 1 + 20 CONTINUE + 30 CONTINUE +C + IF( DISCR ) THEN +C +C Update the input matrix B <-- B*V. +C + CALL DTRMM( 'Right', 'Upper', 'NoTranspose', + $ 'NonUnit', N, M, ONE, DWORK(KV), M, B, + $ LDB ) +C +C Update the feedthrough matrix DR <-- DR*V. +C + K = KV + DO 40 I = 1, M + CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', + $ M-I+1, DWORK(K), M, DR(I,I), LDDR ) + K = K + M + 1 + 40 CONTINUE + END IF +C + IF( IB.EQ.2 ) THEN +C +C Put the 2x2 block in a standard form. +C + L1 = L + 1 + CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), + $ X, Y, PR, SM, CS, SN ) +C +C Apply the transformation to A, B, C and F. +C + IF( L1.LT.NSUP ) + $ CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1), + $ LDA, CS, SN ) + CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) + CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) + IF( P.GT.0 ) + $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) + CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) + END IF + IF( NLOW+IB.LE.NSUP ) THEN +C +C Move the last block(s) to the leading position(s) of +C the bottom block. +C +C Workspace: need MAX(4*N, 4*M, 4*P). +C + NCUR = NSUP - IB +C WHILE (NCUR >= NLOW) DO + 50 IF( NCUR.GE.NLOW ) THEN +C +C Loop for positioning of the last block. +C +C Determine the dimension of the current block. +C + IB1 = 1 + IF( NCUR.GT.NLOW ) THEN + IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 + END IF + NB = IB1 + IB +C +C Initialize the local transformation matrix Z. +C + CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) + L = NCUR - IB1 + 1 +C +C Exchange two adjacent blocks and accumulate the +C transformations in Z. +C + CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, IB1, + $ IB, DWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Apply the transformation to the rest of A. +C + L1 = L + NB + IF( L1.LE.NSUP ) THEN + CALL DGEMM( 'Transpose', 'NoTranspose', NB, + $ NSUP-L1+1, NB, ONE, Z, 4, A(L,L1), + $ LDA, ZERO, DWORK, NB ) + CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, NB, + $ A(L,L1), LDA ) + END IF + CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, NB, + $ NB, ONE, A(1,L), LDA, Z, 4, ZERO, + $ DWORK, N ) + CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), + $ LDA ) +C +C Apply the transformation to B, C and F. +C + CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, NB, + $ ONE, Z, 4, B(L,1), LDB, ZERO, DWORK, + $ NB ) + CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), + $ LDB ) +C + IF( P.GT.0 ) THEN + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NB, + $ NB, ONE, C(1,L), LDC, Z, 4, ZERO, + $ DWORK, P ) + CALL DLACPY( 'Full', P, NB, DWORK, P, + $ C(1,L), LDC ) + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, + $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, + $ DWORK, M ) + CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), + $ LDCR ) +C + NCUR = NCUR - IB1 + GO TO 50 + END IF +C END WHILE 50 +C + END IF + NLOW = NLOW + IB + END IF + GO TO 10 + END IF +C END WHILE 10 +C + NQ = NSUP + NR = NSUP - NFP +C +C Annihilate the elements below the first subdiagonal of A. +C + IF( NQ.GT.2 ) + $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) + END IF +C +C Compute C <-- CQ = C + D*F and D <-- DQ = D*DR. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, + $ CR, LDCR, ONE, C, LDC ) + IF( DISCR ) + $ CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, + $ ONE, DR, LDDR, D, LDD ) +C + DWORK(1) = MAX( WRKOPT, DBLE( MAX( M*(M+2), 4*M, 4*P ) ) ) +C + RETURN +C *** Last line of SB08DD *** + END diff --git a/mex/sources/libslicot/SB08ED.f b/mex/sources/libslicot/SB08ED.f new file mode 100644 index 000000000..b171c4a16 --- /dev/null +++ b/mex/sources/libslicot/SB08ED.f @@ -0,0 +1,359 @@ + SUBROUTINE SB08ED( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, + $ D, LDD, NQ, NR, BR, LDBR, DR, LDDR, TOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct, for a given system G = (A,B,C,D), an output +C injection matrix H and an orthogonal transformation matrix Z, such +C that the systems +C +C Q = (Z'*(A+H*C)*Z, Z'*(B+H*D), C*Z, D) +C and +C R = (Z'*(A+H*C)*Z, Z'*H, C*Z, I) +C +C provide a stable left coprime factorization of G in the form +C -1 +C G = R * Q, +C +C where G, Q and R are the corresponding transfer-function matrices. +C The resulting state dynamics matrix of the systems Q and R has +C eigenvalues lying inside a given stability domain. +C The Z matrix is not explicitly computed. +C +C Note: If the given state-space representation is not detectable, +C the undetectable part of the original system is automatically +C deflated and the order of the systems Q and R is accordingly +C reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrices B +C and BR, and the number of columns of the matrix C. +C N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B and D. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows +C of the matrices C, D and DR, and the number of columns of +C the matrices BR and DR. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION array, dimension (2) +C ALPHA(1) contains the desired stability degree to be +C assigned for the eigenvalues of A+H*C, and ALPHA(2) +C the stability margin. The eigenvalues outside the +C ALPHA(2)-stability region will be assigned to have the +C real parts equal to ALPHA(1) < 0 and unmodified +C imaginary parts for a continuous-time system +C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 +C for a discrete-time system (DICO = 'D'). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading NQ-by-NQ part of this array contains +C the leading NQ-by-NQ part of the matrix Z'*(A+H*C)*Z, the +C state dynamics matrix of the numerator factor Q, in a +C real Schur form. The leading NR-by-NR part of this matrix +C represents the state dynamics matrix of a minimal +C realization of the denominator factor R. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix of the system. +C On exit, the leading NQ-by-M part of this array contains +C the leading NQ-by-M part of the matrix Z'*(B+H*D), the +C input/state matrix of the numerator factor Q. +C The remaining part of this array is needed as workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix of the system. +C On exit, the leading P-by-NQ part of this array contains +C the leading P-by-NQ part of the matrix C*Z, the +C state/output matrix of the numerator factor Q. +C The first NR columns of this array represent the +C state/output matrix of a minimal realization of the +C denominator factor R. +C The remaining part of this array is needed as workspace. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P), if N > 0. +C LDC >= 1, if N = 0. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) +C The leading P-by-M part of this array must contain the +C input/output matrix. D represents also the input/output +C matrix of the numerator factor Q. +C This array is modified internally, but restored on exit. +C The remaining part of this array is needed as workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C NQ (output) INTEGER +C The order of the resulting factors Q and R. +C Generally, NQ = N - NS, where NS is the number of +C unobservable eigenvalues outside the stability region. +C +C NR (output) INTEGER +C The order of the minimal realization of the factor R. +C Generally, NR is the number of observable eigenvalues +C of A outside the stability region (the number of modified +C eigenvalues). +C +C BR (output) DOUBLE PRECISION array, dimension (LDBR,P) +C The leading NQ-by-P part of this array contains the +C leading NQ-by-P part of the output injection matrix +C Z'*H, which moves the eigenvalues of A lying outside +C the ALPHA-stable region to values on the ALPHA-stability +C boundary. The first NR rows of this matrix form the +C input/state matrix of a minimal realization of the +C denominator factor R. +C +C LDBR INTEGER +C The leading dimension of array BR. LDBR >= MAX(1,N). +C +C DR (output) DOUBLE PRECISION array, dimension (LDDR,P) +C The leading P-by-P part of this array contains an +C identity matrix representing the input/output matrix +C of the denominator factor R. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C C are considered zero (used for observability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(C), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(C) denotes +C the infinity-norm of C. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(H) <= 10*NORM(A)/NORM(C) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + H*C)*Z +C along the diagonal. +C +C METHOD +C +C The subroutine uses the right coprime factorization algorithm +C of [1] applied to G'. +C +C REFERENCES +C +C [1] Varga A. +C Coprime factors model reduction method based on +C square-root balancing-free techniques. +C System Analysis, Modelling and Simulation, +C vol. 11, pp. 303-311, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine LCFS. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C May 2003, A. Varga, DLR Oberpfaffenhofen. +C Nov 2003, A. Varga, DLR Oberpfaffenhofen. +C Sep. 2005, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDBR, LDC, LDD, LDDR, + $ LDWORK, M, N, NQ, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), BR(LDBR,*), + $ C(LDC,*), D(LDD,*), DR(LDDR,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER KBR, KW +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External subroutines .. + EXTERNAL AB07MD, DLASET, MA02AD, MA02BD, SB08FD, TB01XD, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT.( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE + $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) + $ .OR. + $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO ) + $ ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAX( M, P ) ) ) + $ THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, M, P ) ) THEN + INFO = -13 + ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*P + MAX( N*(N+5), 5*P, 4*M ) ) ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, P ).EQ.0 ) THEN + NQ = 0 + NR = 0 + DWORK(1) = ONE + CALL DLASET( 'Full', P, P, ZERO, ONE, DR, LDDR ) + RETURN + END IF +C +C Compute the dual system G' = (A',C',B',D'). +C + CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) +C +C Compute the right coprime factorization of G' with +C prescribed stability degree. +C +C Workspace needed: P*N; +C Additional workspace: need MAX( N*(N+5), 5*P, 4*M ); +C prefer larger. +C + KBR = 1 + KW = KBR + P*N + CALL SB08FD( DICO, N, P, M, ALPHA, A, LDA, B, LDB, C, LDC, D, LDD, + $ NQ, NR, DWORK(KBR), P, DR, LDDR, TOL, DWORK(KW), + $ LDWORK-KW+1, IWARN, INFO ) + IF( INFO.EQ.0 ) THEN +C +C Determine the elements of the left coprime factorization from +C those of the computed right coprime factorization and make the +C state-matrix upper real Schur. +C + CALL TB01XD( 'D', NQ, P, M, MAX( 0, NQ-1 ), MAX( 0, NQ-1 ), + $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) +C + CALL MA02AD( 'Full', P, NQ, DWORK(KBR), P, BR, LDBR ) + CALL MA02BD( 'Left', NQ, P, BR, LDBR ) +C + END IF +C + DWORK(1) = DWORK(KW) + DBLE( KW-1 ) +C + RETURN +C *** Last line of SB08ED *** + END diff --git a/mex/sources/libslicot/SB08FD.f b/mex/sources/libslicot/SB08FD.f new file mode 100644 index 000000000..54a21b1d9 --- /dev/null +++ b/mex/sources/libslicot/SB08FD.f @@ -0,0 +1,630 @@ + SUBROUTINE SB08FD( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C, LDC, + $ D, LDD, NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct, for a given system G = (A,B,C,D), a feedback +C matrix F and an orthogonal transformation matrix Z, such that +C the systems +C +C Q = (Z'*(A+B*F)*Z, Z'*B, (C+D*F)*Z, D) +C and +C R = (Z'*(A+B*F)*Z, Z'*B, F*Z, I) +C +C provide a stable right coprime factorization of G in the form +C -1 +C G = Q * R , +C +C where G, Q and R are the corresponding transfer-function matrices. +C The resulting state dynamics matrix of the systems Q and R has +C eigenvalues lying inside a given stability domain. +C The Z matrix is not explicitly computed. +C +C Note: If the given state-space representation is not stabilizable, +C the unstabilizable part of the original system is automatically +C deflated and the order of the systems Q and R is accordingly +C reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the state vector, i.e. the order of the +C matrix A, and also the number of rows of the matrix B and +C the number of columns of the matrices C and CR. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B, D and DR and the number of rows of the +C matrices CR and DR. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows +C of the matrices C and D. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION array, dimension (2) +C ALPHA(1) contains the desired stability degree to be +C assigned for the eigenvalues of A+B*F, and ALPHA(2) +C the stability margin. The eigenvalues outside the +C ALPHA(2)-stability region will be assigned to have the +C real parts equal to ALPHA(1) < 0 and unmodified +C imaginary parts for a continuous-time system +C (DICO = 'C'), or moduli equal to 0 <= ALPHA(2) < 1 +C for a discrete-time system (DICO = 'D'). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading NQ-by-NQ part of this array contains +C the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the +C state dynamics matrix of the numerator factor Q, in a +C real Schur form. The trailing NR-by-NR part of this matrix +C represents the state dynamics matrix of a minimal +C realization of the denominator factor R. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix. +C On exit, the leading NQ-by-M part of this array contains +C the leading NQ-by-M part of the matrix Z'*B, the +C input/state matrix of the numerator factor Q. The last +C NR rows of this matrix form the input/state matrix of +C a minimal realization of the denominator factor R. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-NQ part of this array contains +C the leading P-by-NQ part of the matrix (C+D*F)*Z, +C the state/output matrix of the numerator factor Q. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C input/output matrix. D represents also the input/output +C matrix of the numerator factor Q. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C NQ (output) INTEGER +C The order of the resulting factors Q and R. +C Generally, NQ = N - NS, where NS is the number of +C uncontrollable eigenvalues outside the stability region. +C +C NR (output) INTEGER +C The order of the minimal realization of the factor R. +C Generally, NR is the number of controllable eigenvalues +C of A outside the stability region (the number of modified +C eigenvalues). +C +C CR (output) DOUBLE PRECISION array, dimension (LDCR,N) +C The leading M-by-NQ part of this array contains the +C leading M-by-NQ part of the feedback matrix F*Z, which +C moves the eigenvalues of A lying outside the ALPHA-stable +C region to values which are on the ALPHA-stability +C boundary. The last NR columns of this matrix form the +C state/output matrix of a minimal realization of the +C denominator factor R. +C +C LDCR INTEGER +C The leading dimension of array CR. LDCR >= MAX(1,M). +C +C DR (output) DOUBLE PRECISION array, dimension (LDDR,M) +C The leading M-by-M part of this array contains an +C identity matrix representing the input/output matrix +C of the denominator factor R. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,M). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The absolute tolerance level below which the elements of +C B are considered zero (used for controllability tests). +C If the user sets TOL <= 0, then an implicitly computed, +C default tolerance, defined by TOLDEF = N*EPS*NORM(B), +C is used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH) and NORM(B) denotes +C the 1-norm of B. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LWORK >= MAX( 1, N*(N+5), 5*M, 4*P ). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = K: K violations of the numerical stability condition +C NORM(F) <= 10*NORM(A)/NORM(B) occured during the +C assignment of eigenvalues. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A to a real Schur form failed; +C = 2: a failure was detected during the ordering of the +C real Schur form of A, or in the iterative process +C for reordering the eigenvalues of Z'*(A + B*F)*Z +C along the diagonal. +C +C METHOD +C +C The subroutine is based on the factorization algorithm of [1]. +C +C REFERENCES +C +C [1] Varga A. +C Coprime factors model reduction method based on +C square-root balancing-free techniques. +C System Analysis, Modelling and Simulation, +C vol. 11, pp. 303-311, 1993. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires no more than 14N floating point +C operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine RCFS. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Mar. 2003, May 2003, A. Varga, German Aerospace Center. +C May 2003, V. Sima, Research Institute for Informatics, Bucharest. +C Sep. 2005, A. Varga, German Aerospace Center. +C +C KEYWORDS +C +C Coprime factorization, eigenvalue, eigenvalue assignment, +C feedback control, pole placement, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TEN, ZERO + PARAMETER ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO + INTEGER INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR, + $ LDWORK, M, N, NQ, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHA(*), B(LDB,*), C(LDC,*), + $ CR(LDCR,*), D(LDD,*), DR(LDDR,*), DWORK(*) +C .. Local Scalars .. + LOGICAL DISCR + INTEGER I, IB, IB1, J, K, KFI, KG, KW, KWI, KWR, KZ, L, + $ L1, NB, NCUR, NCUR1, NFP, NLOW, NMOVES, NSUP + DOUBLE PRECISION BNORM, CS, PR, RMAX, SM, SN, TOLER, WRKOPT, X, Y +C .. Local Arrays .. + DOUBLE PRECISION A2(2,2), Z(4,4) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 + LOGICAL LSAME + EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT, + $ SB01BY, TB01LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT +C +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + IWARN = 0 + INFO = 0 +C +C Check the scalar input parameters. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( ( DISCR .AND. ( ALPHA(1).LT.ZERO .OR. ALPHA(1).GE.ONE + $ .OR. ALPHA(2).LT.ZERO .OR. ALPHA(2).GE.ONE ) ) + $ .OR. + $ ( .NOT.DISCR .AND. ( ALPHA(1).GE.ZERO .OR. ALPHA(2).GE.ZERO ) + $ ) ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN + INFO = -17 + ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), 5*M, 4*P ) ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08FD', -INFO ) + RETURN + END IF +C +C Set DR = I and quick return if possible. +C + NR = 0 + CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR ) + IF( MIN( N, M ).EQ.0 ) THEN + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Set F = 0 in the array CR. +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR ) +C +C Compute the norm of B and set the default tolerance if necessary. +C + BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK ) + TOLER = TOL + IF( TOLER.LE.ZERO ) + $ TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' ) + IF( BNORM.LE.TOLER ) THEN + NQ = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Compute the bound for the numerical stability condition. +C + RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM +C +C Allocate working storage. +C + KZ = 1 + KWR = KZ + N*N + KWI = KWR + N + KW = KWI + N +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- Z'*A*Z and accumulate the +C transformations in Z. The separation of spectrum of A is +C performed such that the leading NFP-by-NFP submatrix of A +C corresponds to the "stable" eigenvalues which will be not +C modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A +C corresponds to the "unstable" eigenvalues to be modified. +C Apply the transformation to B and C: B <- Z'*B and C <- C*Z. +C +C Workspace needed: N*(N+2); +C Additional workspace: need 3*N; +C prefer larger. +C + CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA(2), A, LDA, + $ B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = DWORK(KW) + DBLE( KW-1 ) +C +C Perform the pole assignment if there exist "unstable" eigenvalues. +C + NQ = N + IF( NFP.LT.N ) THEN + KG = 1 + KFI = KG + 2*M + KW = KFI + 2*M +C +C Set the limits for the bottom diagonal block. +C + NLOW = NFP + 1 + NSUP = N +C +C WHILE (NLOW <= NSUP) DO + 10 IF( NLOW.LE.NSUP ) THEN +C +C Main loop for assigning one or two poles. +C +C Determine the dimension of the last block. +C + IB = 1 + IF( NLOW.LT.NSUP ) THEN + IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2 + END IF + L = NSUP - IB + 1 +C +C Save the last IB rows of B in G. +C + CALL DLACPY( 'Full', IB, M, B(L,1), LDB, DWORK(KG), IB ) +C +C Check the controllability of the last block. +C + IF( DLANGE( '1-norm', IB, M, DWORK(KG), IB, DWORK(KW) ) + $ .LE.TOLER )THEN +C +C Deflate the uncontrollable block and resume the +C main loop. +C + NSUP = NSUP - IB + ELSE +C +C Form the IBxIB matrix A2 from the last diagonal block and +C set the pole(s) to be assigned. +C + A2(1,1) = A(L,L) + IF( IB.EQ.1 ) THEN + SM = ALPHA(1) + IF( DISCR ) SM = SIGN( ALPHA(1), A2(1,1) ) + PR = ALPHA(1) + ELSE + A2(1,2) = A(L,NSUP) + A2(2,1) = A(NSUP,L) + A2(2,2) = A(NSUP,NSUP) + SM = ALPHA(1) + ALPHA(1) + PR = ALPHA(1)*ALPHA(1) + IF( DISCR ) THEN + X = A2(1,1) + Y = SQRT( ABS( A2(1,2)*A2(2,1) ) ) + SM = SM * X / DLAPY2( X, Y ) + ELSE + PR = PR - A2(1,2)*A2(2,1) + END IF + END IF +C +C Determine the M-by-IB feedback matrix FI which assigns +C the selected IB poles for the pair (A2,G). +C +C Workspace needed: 5*M. +C + CALL SB01BY( IB, M, SM, PR, A2, DWORK(KG), DWORK(KFI), + $ TOLER, DWORK(KW), INFO ) + IF( INFO.NE.0 ) THEN +C +C Uncontrollable 2x2 block with double real eigenvalues +C which due to roundoff appear as a pair of complex +C conjugated eigenvalues. +C One of them can be elliminated using the information +C in DWORK(KFI) and DWORK(KFI+M). +C + CS = DWORK(KFI) + SN = -DWORK(KFI+M) +C +C Apply the Givens transformation to A, B, C and F. +C + L1 = L + 1 + CALL DROT( NSUP-L+1, A(L1,L), LDA, A(L,L), + $ LDA, CS, SN ) + CALL DROT( L1, A(1,L1), 1, A(1,L), 1, CS, SN ) + CALL DROT( M, B(L1,1), LDB, B(L,1), LDB, CS, SN ) + IF( P.GT.0 ) + $ CALL DROT( P, C(1,L1), 1, C(1,L), 1, CS, SN ) + CALL DROT( M, CR(1,L1), 1, CR(1,L), 1, CS, SN ) +C +C Deflate the uncontrollable block and resume the +C main loop. +C + A(L1,L) = ZERO + NSUP = NSUP - 1 + INFO = 0 + GO TO 10 + END IF +C +C Check for possible numerical instability. +C + IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) ) + $ .GT.RMAX ) IWARN = IWARN + 1 +C +C Update the feedback matrix F <-- F + [0 FI] in CR. +C + K = KFI + DO 30 J = L, L + IB - 1 + DO 20 I = 1, M + CR(I,J) = CR(I,J) + DWORK(K) + K = K + 1 + 20 CONTINUE + 30 CONTINUE +C +C Update the state matrix A <-- A + B*[0 FI]. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M, + $ ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L), + $ LDA ) + IF( IB.EQ.2 ) THEN +C +C Try to split the 2x2 block and standardize it. +C + L1 = L + 1 + CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1), + $ X, Y, PR, SM, CS, SN ) +C +C Apply the transformation to A, B, C and F. +C + IF( L1.LT.NSUP ) + $ CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1), + $ LDA, CS, SN ) + CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN ) + CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN ) + IF( P.GT.0 ) + $ CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN ) + CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN ) + END IF + IF( NLOW+IB.LE.NSUP ) THEN +C +C Move the last block(s) to the leading position(s) of +C the bottom block. +C +C Workspace: need MAX(4*N, 4*M, 4*P). +C + NCUR1 = NSUP - IB + NMOVES = 1 + IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN + IB = 1 + NMOVES = 2 + END IF +C +C WHILE (NMOVES > 0) DO + 40 IF( NMOVES.GT.0 ) THEN + NCUR = NCUR1 +C +C WHILE (NCUR >= NLOW) DO + 50 IF( NCUR.GE.NLOW ) THEN +C +C Loop for positioning of the last block. +C +C Determine the dimension of the current block. +C + IB1 = 1 + IF( NCUR.GT.NLOW ) THEN + IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2 + END IF + NB = IB1 + IB +C +C Initialize the local transformation matrix Z. +C + CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 ) + L = NCUR - IB1 + 1 +C +C Exchange two adjacent blocks and accumulate the +C transformations in Z. +C + CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, + $ IB1, IB, DWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Apply the transformation to the rest of A. +C + L1 = L + NB + IF( L1.LE.NSUP ) THEN + CALL DGEMM( 'Transpose', 'NoTranspose', NB, + $ NSUP-L1+1, NB, ONE, Z, 4, + $ A(L,L1), LDA, ZERO, DWORK, NB ) + CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, + $ NB, A(L,L1), LDA ) + END IF + CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, + $ NB, NB, ONE, A(1,L), LDA, Z, 4, + $ ZERO, DWORK, N ) + CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L), + $ LDA ) +C +C Apply the transformation to B, C and F. +C + CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, + $ NB, ONE, Z, 4, B(L,1), LDB, ZERO, + $ DWORK, NB ) + CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1), + $ LDB ) +C + IF( P.GT.0 ) THEN + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, + $ NB, NB, ONE, C(1,L), LDC, Z, 4, + $ ZERO, DWORK, P ) + CALL DLACPY( 'Full', P, NB, DWORK, P, + $ C(1,L), LDC ) + END IF +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB, + $ NB, ONE, CR(1,L), LDCR, Z, 4, ZERO, + $ DWORK, M ) + CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L), + $ LDCR ) +C + NCUR = NCUR - IB1 + GO TO 50 + END IF +C END WHILE 50 +C + NMOVES = NMOVES - 1 + NCUR1 = NCUR1 + 1 + NLOW = NLOW + IB + GO TO 40 + END IF +C END WHILE 40 +C + ELSE + NLOW = NLOW + IB + END IF + END IF + GO TO 10 + END IF +C END WHILE 10 +C + NQ = NSUP + NR = NSUP - NFP +C +C Annihilate the elements below the first subdiagonal of A. +C + IF( NQ.GT.2 ) + $ CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA ) + END IF +C +C Compute C <-- CQ = C + D*F. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD, + $ CR, LDCR, ONE, C, LDC ) +C + DWORK(1) = MAX( WRKOPT, DBLE( MAX( 5*M, 4*P ) ) ) +C + RETURN +C *** Last line of SB08FD *** + END diff --git a/mex/sources/libslicot/SB08GD.f b/mex/sources/libslicot/SB08GD.f new file mode 100644 index 000000000..0368fdf78 --- /dev/null +++ b/mex/sources/libslicot/SB08GD.f @@ -0,0 +1,256 @@ + SUBROUTINE SB08GD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, BR, + $ LDBR, DR, LDDR, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the state-space representation for the system +C G = (A,B,C,D) from the factors Q = (AQR,BQ,CQR,DQ) and +C R = (AQR,BR,CQR,DR) of its left coprime factorization +C -1 +C G = R * Q, +C +C where G, Q and R are the corresponding transfer-function matrices. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. Also the number of rows of the +C matrices B and BR and the number of columns of the matrix +C C. N represents the order of the systems Q and R. N >= 0. +C +C M (input) INTEGER +C The dimension of input vector, i.e. the number of columns +C of the matrices B and D. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector, i.e. the number of rows of +C the matrices C, D and DR and the number of columns of the +C matrices BR and DR. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix AQR of the systems +C Q and R. +C On exit, the leading N-by-N part of this array contains +C the state dynamics matrix of the system G. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix BQ of the system Q. +C On exit, the leading N-by-M part of this array contains +C the input/state matrix of the system G. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix CQR of the systems +C Q and R. +C On exit, the leading P-by-N part of this array contains +C the state/output matrix of the system G. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix DQ of the system Q. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix of the system G. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C BR (input) DOUBLE PRECISION array, dimension (LDBR,P) +C The leading N-by-P part of this array must contain the +C input/state matrix BR of the system R. +C +C LDBR INTEGER +C The leading dimension of array BR. LDBR >= MAX(1,N). +C +C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,P) +C On entry, the leading P-by-P part of this array must +C contain the input/output matrix DR of the system R. +C On exit, the leading P-by-P part of this array contains +C the LU factorization of the matrix DR, as computed by +C LAPACK Library routine DGETRF. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,P). +C +C Workspace +C +C IWORK INTEGER array, dimension (P) +C +C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*P)) +C On exit, DWORK(1) contains an estimate of the reciprocal +C condition number of the matrix DR. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix DR is singular; +C = 2: the matrix DR is numerically singular (warning); +C the calculations continued. +C +C METHOD +C +C The subroutine computes the matrices of the state-space +C representation G = (A,B,C,D) by using the formulas: +C +C -1 -1 +C A = AQR - BR * DR * CQR, C = DR * CQR, +C -1 -1 +C B = BQ - BR * DR * DQ, D = DR * DQ. +C +C REFERENCES +C +C [1] Varga A. +C Coprime factors model reduction method based on +C square-root balancing-free techniques. +C System Analysis, Modelling and Simulation, +C vol. 11, pp. 303-311, 1993. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine LCFI. +C +C REVISIONS +C +C Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest. +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C +C KEYWORDS +C +C Coprime factorization, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDBR, LDC, LDD, LDDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), BR(LDBR,*), C(LDC,*), + $ D(LDD,*), DR(LDDR,*), DWORK(*) + INTEGER IWORK(*) +C .. Local Scalars + DOUBLE PRECISION DRNORM, RCOND +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Check the scalar input parameters. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDBR.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDDR.LT.MAX( 1, P ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08GD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( P.EQ.0 )THEN + DWORK(1) = ONE + RETURN + END IF +C +C Factor the matrix DR. First, compute the 1-norm. +C + DRNORM = DLANGE( '1-norm', P, P, DR, LDDR, DWORK ) + CALL DGETRF( P, P, DR, LDDR, IWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = 1 + DWORK(1) = ZERO + RETURN + END IF +C -1 +C Compute C = DR * CQR. +C + CALL DGETRS( 'NoTranspose', P, N, DR, LDDR, IWORK, C, LDC, INFO ) +C -1 +C Compute A = AQR - BR * DR * CQR. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, -ONE, BR, LDBR, + $ C, LDC, ONE, A, LDA ) +C -1 +C Compute D = DR * DQ. +C + CALL DGETRS( 'NoTranspose', P, M, DR, LDDR, IWORK, D, LDD, INFO ) +C -1 +C Compute B = BQ - BR * DR * DQ. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, -ONE, BR, LDBR, + $ D, LDD, ONE, B, LDB ) +C +C Estimate the reciprocal condition number of DR. +C Workspace 4*P. +C + CALL DGECON( '1-norm', P, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, + $ INFO ) + IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) + $ INFO = 2 +C + DWORK(1) = RCOND +C + RETURN +C *** Last line of SB08GD *** + END diff --git a/mex/sources/libslicot/SB08HD.f b/mex/sources/libslicot/SB08HD.f new file mode 100644 index 000000000..b1a2227d9 --- /dev/null +++ b/mex/sources/libslicot/SB08HD.f @@ -0,0 +1,267 @@ + SUBROUTINE SB08HD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, CR, + $ LDCR, DR, LDDR, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the state-space representation for the system +C G = (A,B,C,D) from the factors Q = (AQR,BQR,CQ,DQ) and +C R = (AQR,BQR,CR,DR) of its right coprime factorization +C -1 +C G = Q * R , +C +C where G, Q and R are the corresponding transfer-function matrices. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. Also the number of rows of the +C matrix B and the number of columns of the matrices C and +C CR. N represents the order of the systems Q and R. +C N >= 0. +C +C M (input) INTEGER +C The dimension of input vector. Also the number of columns +C of the matrices B, D and DR and the number of rows of the +C matrices CR and DR. M >= 0. +C +C P (input) INTEGER +C The dimension of output vector. Also the number of rows +C of the matrices C and D. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix AQR of the systems +C Q and R. +C On exit, the leading N-by-N part of this array contains +C the state dynamics matrix of the system G. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix BQR of the systems Q and R. +C On exit, the leading N-by-M part of this array contains +C the input/state matrix of the system G. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix CQ of the system Q. +C On exit, the leading P-by-N part of this array contains +C the state/output matrix of the system G. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the input/output matrix DQ of the system Q. +C On exit, the leading P-by-M part of this array contains +C the input/output matrix of the system G. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C CR (input) DOUBLE PRECISION array, dimension (LDCR,N) +C The leading M-by-N part of this array must contain the +C state/output matrix CR of the system R. +C +C LDCR INTEGER +C The leading dimension of array CR. LDCR >= MAX(1,M). +C +C DR (input/output) DOUBLE PRECISION array, dimension (LDDR,M) +C On entry, the leading M-by-M part of this array must +C contain the input/output matrix DR of the system R. +C On exit, the leading M-by-M part of this array contains +C the LU factorization of the matrix DR, as computed by +C LAPACK Library routine DGETRF. +C +C LDDR INTEGER +C The leading dimension of array DR. LDDR >= MAX(1,M). +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (MAX(1,4*M)) +C On exit, DWORK(1) contains an estimate of the reciprocal +C condition number of the matrix DR. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the matrix DR is singular; +C = 2: the matrix DR is numerically singular (warning); +C the calculations continued. +C +C METHOD +C +C The subroutine computes the matrices of the state-space +C representation G = (A,B,C,D) by using the formulas: +C +C -1 -1 +C A = AQR - BQR * DR * CR, B = BQR * DR , +C -1 -1 +C C = CQ - DQ * DR * CR, D = DQ * DR . +C +C REFERENCES +C +C [1] Varga A. +C Coprime factors model reduction method based on +C square-root balancing-free techniques. +C System Analysis, Modelling and Simulation, +C vol. 11, pp. 303-311, 1993. +C +C CONTRIBUTOR +C +C C. Oara and A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 1998. +C Based on the RASP routine RCFI. +C V. Sima, Research Institute for Informatics, Bucharest, Nov. 1998, +C full BLAS 3 version. +C +C REVISIONS +C +C Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven. +C Mar. 2000, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Coprime factorization, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDCR, LDD, LDDR, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*), + $ D(LDD,*), DR(LDDR,*), DWORK(*) + INTEGER IWORK(*) +C .. Local Scalars + DOUBLE PRECISION DRNORM, RCOND +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DTRSM, MA02GD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Check the scalar input parameters. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 )THEN +C +C Error return. +C + CALL XERBLA( 'SB08HD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( M.EQ.0 )THEN + DWORK(1) = ONE + RETURN + END IF +C +C Factor the matrix DR. First, compute the 1-norm. +C + DRNORM = DLANGE( '1-norm', M, M, DR, LDDR, DWORK ) + CALL DGETRF( M, M, DR, LDDR, IWORK, INFO ) + IF( INFO.NE.0 ) THEN + INFO = 1 + DWORK(1) = ZERO + RETURN + END IF +C -1 +C Compute B = BQR * DR , using the factorization P*DR = L*U. +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, M, ONE, + $ DR, LDDR, B, LDB ) + CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', N, M, ONE, + $ DR, LDDR, B, LDB ) + CALL MA02GD( N, B, LDB, 1, M, IWORK, -1 ) +C -1 +C Compute A = AQR - BQR * DR * CR. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, -ONE, B, LDB, + $ CR, LDCR, ONE, A, LDA ) +C -1 +C Compute D = DQ * DR . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M, ONE, + $ DR, LDDR, D, LDD ) + CALL DTRSM( 'Right', 'Lower', 'NoTranspose', 'Unit', P, M, ONE, + $ DR, LDDR, D, LDD ) + CALL MA02GD( P, D, LDD, 1, M, IWORK, -1 ) +C -1 +C Compute C = CQ - DQ * DR * CR. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, -ONE, D, LDD, + $ CR, LDCR, ONE, C, LDC ) +C +C Estimate the reciprocal condition number of DR. +C Workspace 4*M. +C + CALL DGECON( '1-norm', M, DR, LDDR, DRNORM, RCOND, DWORK, IWORK, + $ INFO ) + IF( RCOND.LE.DLAMCH( 'Epsilon' ) ) + $ INFO = 2 +C + DWORK(1) = RCOND +C + RETURN +C *** Last line of SB08HD *** + END diff --git a/mex/sources/libslicot/SB08MD.f b/mex/sources/libslicot/SB08MD.f new file mode 100644 index 000000000..78f6d46c2 --- /dev/null +++ b/mex/sources/libslicot/SB08MD.f @@ -0,0 +1,471 @@ + SUBROUTINE SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a real polynomial E(s) such that +C +C (a) E(-s) * E(s) = A(-s) * A(s) and +C (b) E(s) is stable - that is, all the zeros of E(s) have +C non-positive real parts, +C +C which corresponds to computing the spectral factorization of the +C real polynomial A(s) arising from continuous optimality problems. +C +C The input polynomial may be supplied either in the form +C +C A(s) = a(0) + a(1) * s + ... + a(DA) * s**DA +C +C or as +C +C B(s) = A(-s) * A(s) +C = b(0) + b(1) * s**2 + ... + b(DA) * s**(2*DA) (1) +C +C ARGUMENTS +C +C Mode Parameters +C +C ACONA CHARACTER*1 +C Indicates whether the coefficients of A(s) or B(s) = +C A(-s) * A(s) are to be supplied as follows: +C = 'A': The coefficients of A(s) are to be supplied; +C = 'B': The coefficients of B(s) are to be supplied. +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the polynomials A(s) and E(s). DA >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (DA+1) +C On entry, this array must contain either the coefficients +C of the polynomial A(s) in increasing powers of s if +C ACONA = 'A', or the coefficients of the polynomial B(s) in +C increasing powers of s**2 (see equation (1)) if ACONA = +C 'B'. +C On exit, this array contains the coefficients of the +C polynomial B(s) in increasing powers of s**2. +C +C RES (output) DOUBLE PRECISION +C An estimate of the accuracy with which the coefficients of +C the polynomial E(s) have been computed (see also METHOD +C and NUMERICAL ASPECTS). +C +C E (output) DOUBLE PRECISION array, dimension (DA+1) +C The coefficients of the spectral factor E(s) in increasing +C powers of s. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 5*DA+5. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if on entry, A(I) = 0.0, for I = 1,2,...,DA+1. +C = 2: if on entry, ACONA = 'B' but the supplied +C coefficients of the polynomial B(s) are not the +C coefficients of A(-s) * A(s) for some real A(s); +C in this case, RES and E are unassigned; +C = 3: if the iterative process (see METHOD) has failed to +C converge in 30 iterations; +C = 4: if the last computed iterate (see METHOD) is +C unstable. If ACONA = 'B', then the supplied +C coefficients of the polynomial B(s) may not be the +C coefficients of A(-s) * A(s) for some real A(s). +C +C METHOD +C _ _ +C Let A(s) be the conjugate polynomial of A(s), i.e., A(s) = A(-s). +C +C The method used by the routine is based on applying the +C Newton-Raphson iteration to the function +C _ _ +C F(e) = A * A - e * e, +C +C which leads to the iteration formulae (see [1]): +C +C _(i) (i) _(i) (i) _ ) +C q * x + x * q = 2 A * A ) +C ) for i = 0, 1, 2,... +C (i+1) (i) (i) ) +C q = (q + x )/2 ) +C +C (0) DA +C Starting from q = (1 + s) (which has no zeros in the closed +C (1) (2) (3) +C right half-plane), the sequence of iterates q , q , q ,... +C converges to a solution of F(e) = 0 which has no zeros in the +C open right half-plane. +C +C The iterates satisfy the following conditions: +C +C (i) +C (a) q is a stable polynomial (no zeros in the closed right +C half-plane) and +C +C (i) (i-1) +C (b) q (1) <= q (1). +C +C (i-1) (i) +C The iterative process stops with q , (where i <= 30) if q +C violates either (a) or (b), or if the condition +C _(i) (i) _ +C (c) RES = ||(q q - A A)|| < tol, +C +C is satisfied, where || . || denotes the largest coefficient of +C _(i) (i) _ +C the polynomial (q q - A A) and tol is an estimate of the +C _(i) (i) +C rounding error in the computed coefficients of q q . If there +C is no convergence after 30 iterations then the routine returns +C with the Error Indicator (INFO) set to 3, and the value of RES may +C indicate whether or not the last computed iterate is close to the +C solution. +C +C If ACONA = 'B', then it is possible that the equation e(-s) * +C e(s) = B(s) has no real solution, which will be the case if A(1) +C < 0 or if ( -1)**DA * A(DA+1) < 0. +C +C REFERENCES +C +C [1] Vostry, Z. +C New Algorithm for Polynomial Spectral Factorization with +C Quadratic Convergence II. +C Kybernetika, 12, pp. 248-259, 1976. +C +C NUMERICAL ASPECTS +C +C The conditioning of the problem depends upon the distance of the +C zeros of A(s) from the imaginary axis and on their multiplicity. +C For a well-conditioned problem the accuracy of the computed +C coefficients of E(s) is of the order of RES. However, for problems +C with zeros near the imaginary axis or with multiple zeros, the +C value of RES may be an overestimate of the true accuracy. +C +C FURTHER COMMENTS +C +C In order for the problem e(-s) * e(s) = B(s) to have a real +C solution e(s), it is necessary and sufficient that B(j*omega) +C >= 0 for any purely imaginary argument j*omega (see [1]). +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB08AD by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Factorization, Laplace transform, optimal control, optimal +C filtering, polynomial operations, spectral factorization, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ACONA + INTEGER DA, INFO, LDWORK + DOUBLE PRECISION RES +C .. Array Arguments .. + DOUBLE PRECISION A(*), DWORK(*), E(*) +C .. Local Scalars .. + LOGICAL CONV, LACONA, STABLE + INTEGER BINC, DA1, I, I0, J, K, LAMBDA, LAY, LAYEND, + $ LDIF, LPHEND, LPHI, LQ, M, NC + DOUBLE PRECISION A0, EPS, MU, MUJ, SI, SIGNI, SIGNI0, SIGNJ, + $ SIMIN1, SQRTA0, SQRTMJ, SQRTMU, TOLPHI, W, XDA +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, SB08MY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MOD, SQRT +C .. Executable Statements .. +C + INFO = 0 + LACONA = LSAME( ACONA, 'A' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN + INFO = -1 + ELSE IF( DA.LT.0 ) THEN + INFO = -2 + ELSE IF( LDWORK.LT.5*DA + 5 ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB08MD', -INFO ) + RETURN + END IF +C + IF ( .NOT.LACONA ) THEN + CALL DCOPY( DA+1, A, 1, E, 1 ) + ELSE + W = ZERO + CALL SB08MY( DA, A, E, W ) + END IF +C +C Reduce E such that the first and the last element are non-zero. +C + DA1 = DA + 1 +C +C WHILE ( DA1 >= 1 and E(DA1) = 0 ) DO + 20 IF ( DA1.GE.1 ) THEN + IF ( E(DA1).EQ.ZERO ) THEN + DA1 = DA1 - 1 + GO TO 20 + END IF + END IF +C END WHILE 20 +C + DA1 = DA1 - 1 + IF ( DA1.LT.0 ) THEN + INFO = 1 + RETURN + END IF +C + I0 = 1 +C +C WHILE ( E(I0) = 0 ) DO + 40 IF ( E(I0).EQ.ZERO ) THEN + I0 = I0 + 1 + GO TO 40 + END IF +C END WHILE 40 +C + I0 = I0 - 1 + IF ( I0.NE.0 ) THEN + IF ( MOD( I0, 2 ).EQ.0 ) THEN + SIGNI0 = ONE + ELSE + SIGNI0 = -ONE + END IF +C + DO 60 I = 1, DA1 - I0 + 1 + E(I) = SIGNI0*E(I+I0) + 60 CONTINUE +C + DA1 = DA1 - I0 + END IF + IF ( MOD( DA1, 2 ).EQ.0 ) THEN + SIGNI = ONE + ELSE + SIGNI = -ONE + END IF + NC = DA1 + 1 + IF ( ( E(1).LT.ZERO ) .OR. ( ( E(NC)*SIGNI ).LT.ZERO ) ) THEN + INFO = 2 + RETURN + END IF +C +C Initialization. +C + EPS = DLAMCH( 'Epsilon' ) + SI = ONE/DLAMCH( 'Safe minimum' ) + LQ = 1 + LAY = LQ + NC + LAMBDA = LAY + NC + LPHI = LAMBDA + NC + LDIF = LPHI + NC +C + A0 = E(1) + BINC = 1 +C +C Computation of the starting polynomial and scaling of the input +C polynomial. +C + MU = ( A0/ABS( E(NC) ) )**( ONE/DBLE( DA1 ) ) + MUJ = ONE +C + DO 80 J = 1, NC + W = E(J)*MUJ/A0 + A(J) = W + E(J) = BINC + DWORK(LQ+J-1) = BINC + MUJ = MUJ*MU + BINC = BINC*( NC - J )/J + 80 CONTINUE +C + CONV = .FALSE. + STABLE = .TRUE. +C +C The contents of the arrays is, cf [1], +C +C E : the last computed stable polynomial q ; +C i-1 +C DWORK(LAY+1,...,LAY+DA1-1) : a'(1), ..., a'(DA1-1), these values +C are changed during the computation +C into y; +C (LAMBDA+1,...,LAMBDA+DA1-2) : lambda(1), ..., lambda(DA1-2), +C the factors of the Routh +C stability test, (lambda(i) is +C P(i) in [1]); +C (LPHI+1,...,LPHI+DA1-1) : phi(1), ..., phi(DA1-1), the values +C phi(i,j), see [1], scheme (11); +C (LDIF,...,LDIF+DA1) : the coeffs of q (-s) * q (s) - b(s). +C i i +C DWORK(LQ,...,LQ+DA1) : the last computed polynomial q . +C i + I = 0 +C +C WHILE ( I < 30 and CONV = FALSE and STABLE = TRUE ) DO + 100 IF ( I.LT.30 .AND. .NOT.CONV .AND. STABLE ) THEN + I = I + 1 + CALL DCOPY( NC, A, 1, DWORK(LAY), 1 ) + CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LPHI), 1 ) + M = DA1/2 + LAYEND = LAY + DA1 + LPHEND = LPHI + DA1 + XDA = A(NC)/DWORK(LQ+DA1) +C + DO 120 K = 1, M + DWORK(LAY+K) = DWORK(LAY+K) - DWORK(LPHI+2*K) + DWORK(LAYEND-K) = DWORK(LAYEND-K) - DWORK(LPHEND-2*K)*XDA + 120 CONTINUE +C +C Computation of lambda(k) and y(k). +C + K = 1 +C +C WHILE ( K <= DA1 - 2 and STABLE = TRUE ) DO + 140 IF ( ( K.LE.( DA1 - 2 ) ) .AND. STABLE ) THEN + IF ( DWORK(LPHI+K).LE.ZERO ) STABLE = .FALSE. + IF ( STABLE ) THEN + W = DWORK(LPHI+K-1)/DWORK(LPHI+K) + DWORK(LAMBDA+K) = W + CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, + $ DWORK(LPHI+K+1), 2 ) + W = DWORK(LAY+K)/DWORK(LPHI+K) + DWORK(LAY+K) = W + CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2, + $ DWORK(LAY+K+1), 1 ) + K = K + 1 + END IF + GO TO 140 + END IF +C END WHILE 140 +C + IF ( DWORK(LPHI+DA1-1).LE.ZERO ) THEN + STABLE = .FALSE. + ELSE + DWORK(LAY+DA1-1) = DWORK(LAY+DA1-1)/DWORK(LPHI+DA1-1) + END IF +C +C STABLE = The polynomial q is stable. +C i-1 + IF ( STABLE ) THEN +C +C Computation of x and q . +C i i +C + DO 160 K = DA1 - 2, 1, -1 + W = DWORK(LAMBDA+K) + CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LAY+K+1), 2, + $ DWORK(LAY+K), 2 ) + 160 CONTINUE +C + DWORK(LAY+DA1) = XDA +C + CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) + SIMIN1 = SI + SI = DWORK(LQ) + SIGNJ = -ONE +C + DO 180 J = 1, DA1 + W = HALF*( DWORK(LQ+J) + SIGNJ*DWORK(LAY+J) ) + DWORK(LQ+J) = W + SI = SI + W + SIGNJ = -SIGNJ + 180 CONTINUE +C + TOLPHI = EPS + CALL SB08MY( DA1, E, DWORK(LDIF), TOLPHI ) + CALL DAXPY( NC, -ONE, A, 1, DWORK(LDIF), 1 ) + RES = ABS( DWORK( IDAMAX( NC, DWORK(LDIF), 1 ) + LDIF-1 ) ) +C +C Convergency test. +C + IF ( ( SI.GT.SIMIN1 ) .OR. ( RES.LT.TOLPHI ) ) THEN + CONV = .TRUE. + END IF + GO TO 100 + END IF + END IF +C END WHILE 100 +C +C Backscaling. +C + MU = ONE/MU + SQRTA0 = SQRT( A0 ) + SQRTMU = SQRT( MU ) + MUJ = ONE + SQRTMJ = ONE +C + DO 200 J = 1, NC + E(J) = E(J)*SQRTA0*SQRTMJ + A(J) = A(J)*A0*MUJ + MUJ = MUJ*MU + SQRTMJ = SQRTMJ*SQRTMU + 200 CONTINUE +C + IF ( I0.NE.0 ) THEN +C + DO 220 J = NC, 1, -1 + E(I0+J) = E(J) + A(I0+J) = SIGNI0*A(J) + 220 CONTINUE +C + DO 240 J = 1, I0 + E(J) = ZERO + A(J) = ZERO + 240 CONTINUE +C + END IF +C + IF ( .NOT.CONV ) THEN + IF ( STABLE ) THEN + INFO = 3 + ELSE + INFO = 4 + END IF + END IF +C + RETURN +C *** Last line of SB08MD *** + END diff --git a/mex/sources/libslicot/SB08MY.f b/mex/sources/libslicot/SB08MY.f new file mode 100644 index 000000000..085be630a --- /dev/null +++ b/mex/sources/libslicot/SB08MY.f @@ -0,0 +1,102 @@ + SUBROUTINE SB08MY( DA, A, B, EPSB ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of B(s) = A(s) * A(-s) and a norm +C for the accuracy of the computed coefficients. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the polynomials A(s) and B(s). DA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (DA+1) +C This array must contain the coefficients of the polynomial +C A(s) in increasing powers of s. +C +C B (output) DOUBLE PRECISION array, dimension (DA+1) +C This array contains the coefficients of the polynomial +C B(s) in increasing powers of s**2. +C +C EPSB (input/output) DOUBLE PRECISION +C On entry, EPSB must contain the machine precision (see +C LAPACK Library routine DLAMCH). +C On exit, EPSB contains an updated value, using a norm +C for the accuracy of the computed coefficients. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB08AZ by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Laplace transform, polynomial operations, spectral factorization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO=2.0D0, + $ THREE = 3.0D0 ) +C .. Scalar Arguments .. + INTEGER DA + DOUBLE PRECISION EPSB +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*) +C .. Local Scalars .. + INTEGER I, K + DOUBLE PRECISION MAXSA, SA, SABS, SIGNI, SIGNK, TERM +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. Executable Statements .. +C + SIGNI = ONE + MAXSA = ZERO +C + DO 40 I = 0, DA + SABS = A(I+1)**2 + SA = SIGNI*SABS + SIGNK = -TWO*SIGNI +C + DO 20 K = 1, MIN( I, DA - I ) + TERM = SIGNK*A(I-K+1)*A(I+K+1) + SA = SA + TERM + SABS = SABS + ABS( TERM ) + SIGNK = -SIGNK + 20 CONTINUE +C + B(I+1) = SA + MAXSA = MAX( MAXSA, SABS ) + SIGNI = -SIGNI + 40 CONTINUE +C + EPSB = THREE*MAXSA*EPSB +C + RETURN +C *** Last line of SB08MY *** + END diff --git a/mex/sources/libslicot/SB08ND.f b/mex/sources/libslicot/SB08ND.f new file mode 100644 index 000000000..ced79b329 --- /dev/null +++ b/mex/sources/libslicot/SB08ND.f @@ -0,0 +1,382 @@ + SUBROUTINE SB08ND( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a real polynomial E(z) such that +C +C (a) E(1/z) * E(z) = A(1/z) * A(z) and +C (b) E(z) is stable - that is, E(z) has no zeros with modulus +C greater than 1, +C +C which corresponds to computing the spectral factorization of the +C real polynomial A(z) arising from discrete optimality problems. +C +C The input polynomial may be supplied either in the form +C +C A(z) = a(0) + a(1) * z + ... + a(DA) * z**DA +C +C or as +C +C B(z) = A(1/z) * A(z) +C = b(0) + b(1) * (z + 1/z) + ... + b(DA) * (z**DA + 1/z**DA) +C (1) +C +C ARGUMENTS +C +C Mode Parameters +C +C ACONA CHARACTER*1 +C Indicates whether the coefficients of A(z) or B(z) = +C A(1/z) * A(z) are to be supplied as follows: +C = 'A': The coefficients of A(z) are to be supplied; +C = 'B': The coefficients of B(z) are to be supplied. +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the polynomials A(z) and E(z). DA >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (DA+1) +C On entry, if ACONA = 'A', this array must contain the +C coefficients of the polynomial A(z) in increasing powers +C of z, and if ACONA = 'B', this array must contain the +C coefficients b ,b ,...,b of the polynomial B(z) in +C 0 1 DA +C equation (1). That is, A(i) = b for i = 1,2,...,DA+1. +C i-1 +C On exit, this array contains the coefficients of the +C polynomial B(z) in eqation (1). Specifically, A(i) +C contains b , for i = 1,2,...DA+1. +C i-1 +C +C RES (output) DOUBLE PRECISION +C An estimate of the accuracy with which the coefficients of +C the polynomial E(z) have been computed (see also METHOD +C and NUMERICAL ASPECTS). +C +C E (output) DOUBLE PRECISION array, dimension (DA+1) +C The coefficients of the spectral factor E(z) in increasing +C powers of z. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= 5*DA+5. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 2: if on entry, ACONA = 'B' but the supplied +C coefficients of the polynomial B(z) are not the +C coefficients of A(1/z) * A(z) for some real A(z); +C in this case, RES and E are unassigned; +C = 3: if the iterative process (see METHOD) has failed to +C converge in 30 iterations; +C = 4: if the last computed iterate (see METHOD) is +C unstable. If ACONA = 'B', then the supplied +C coefficients of the polynomial B(z) may not be the +C coefficients of A(1/z) * A(z) for some real A(z). +C +C METHOD +C _ _ +C Let A(z) be the conjugate polynomial of A(z), i.e., A(z) = A(1/z). +C +C The method used by the routine is based on applying the +C Newton-Raphson iteration to the function +C _ _ +C F(e) = A * A - e * e, +C +C which leads to the iteration formulae (see [1] and [2]) +C +C _(i) (i) _(i) (i) _ ) +C q * x + x * q = 2 A * A ) +C ) for i = 0, 1, 2,... +C (i+1) (i) (i) ) +C q = (q + x )/2 ) +C +C The iteration starts from +C +C (0) DA +C q (z) = (b(0) + b(1) * z + ... + b(DA) * z ) / SQRT( b(0)) +C +C which is a Hurwitz polynomial that has no zeros in the closed unit +C (i) +C circle (see [2], Theorem 3). Then lim q = e, the convergence is +C uniform and e is a Hurwitz polynomial. +C +C The iterates satisfy the following conditions: +C (i) +C (a) q has no zeros in the closed unit circle, +C (i) (i-1) +C (b) q <= q and +C 0 0 +C DA (i) 2 DA 2 +C (c) SUM (q ) - SUM (A ) >= 0. +C k=0 k k=0 k +C (i) +C The iterative process stops if q violates (a), (b) or (c), +C or if the condition +C _(i) (i) _ +C (d) RES = ||(q q - A A)|| < tol, +C +C is satisfied, where || . || denotes the largest coefficient of +C _(i) (i) _ +C the polynomial (q q - A A) and tol is an estimate of the +C _(i) (i) +C rounding error in the computed coefficients of q q . If +C (i-1) +C condition (a) or (b) is violated then q is taken otherwise +C (i) +C q is used. Thus the computed reciprocal polynomial E(z) = z**DA +C * q(1/z) is stable. If there is no convergence after 30 iterations +C then the routine returns with the Error Indicator (INFO) set to 3, +C and the value of RES may indicate whether or not the last computed +C iterate is close to the solution. +C (0) +C If ACONA = 'B', then it is possible that q is not a Hurwitz +C polynomial, in which case the equation e(1/z) * e(z) = B(z) has no +C real solution (see [2], Theorem 3). +C +C REFERENCES +C +C [1] Kucera, V. +C Discrete Linear Control, The polynomial Approach. +C John Wiley & Sons, Chichester, 1979. +C +C [2] Vostry, Z. +C New Algorithm for Polynomial Spectral Factorization with +C Quadratic Convergence I. +C Kybernetika, 11, pp. 415-422, 1975. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB08BD by F. Delebecque and +C A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Factorization, Laplace transform, optimal control, optimal +C filtering, polynomial operations, spectral factorization, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ TWO = 2.0D0 ) +C .. Scalar Arguments .. + CHARACTER ACONA + INTEGER DA, INFO, LDWORK + DOUBLE PRECISION RES +C .. Array Arguments .. + DOUBLE PRECISION A(*), DWORK(*), E(*) +C .. Local Scalars .. + LOGICAL CONV, HURWTZ, LACONA + INTEGER I, J, K, LALPHA, LAMBDA, LETA, LQ, LRO, NC, NCK + DOUBLE PRECISION A0, RES0, S, SA0, TOLQ, W +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, DSWAP, SB08NY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C + INFO = 0 + LACONA = LSAME( ACONA, 'A' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN + INFO = -1 + ELSE IF( DA.LT.0 ) THEN + INFO = -2 + ELSE IF( LDWORK.LT.5*DA + 5 ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB08ND', -INFO ) + RETURN + END IF +C + NC = DA + 1 + IF ( .NOT.LACONA ) THEN + IF ( A(1).LE.ZERO ) THEN + INFO = 2 + RETURN + END IF + CALL DCOPY( NC, A, 1, E, 1 ) + ELSE + CALL SB08NY( DA, A, E, W ) + END IF +C +C Initialization. +C + LALPHA = 1 + LRO = LALPHA + NC + LETA = LRO + NC + LAMBDA = LETA + NC + LQ = LAMBDA + NC +C + A0 = E(1) + SA0 = SQRT( A0 ) + S = ZERO +C + DO 20 J = 1, NC + W = E(J) + A(J) = W + W = W/SA0 + E(J) = W + DWORK(LQ-1+J) = W + S = S + W**2 + 20 CONTINUE +C + RES0 = S - A0 +C +C The contents of the arrays is, cf [1], Section 7.6, +C +C E : the last computed Hurwitz polynomial q ; +C i-1 +C DWORK(LALPHA,..,LALPHA+DA-K) : alpha(k,0),...alpha(k,n-k); +C (LRO,...,LRO+DA-K) : alpha(k,n-k),...,alpha(k); +C (LETA,...,LETA+DA) : eta(0),...,eta(n); +C (LAMBDA,...,LAMBDA+DA-1) : lambda(0),...,lambda(n-1) +C +C DWORK(LQ,...,LQ+DA) : the last computed polynomial q . +C i + I = 0 + CONV = .FALSE. + HURWTZ = .TRUE. +C +C WHILE ( I < 30 and CONV = FALSE and HURWTZ = TRUE ) DO + 40 IF ( I.LT.30 .AND. .NOT.CONV .AND. HURWTZ ) THEN + I = I + 1 + CALL DCOPY( NC, A, 1, DWORK(LETA), 1 ) + CALL DSCAL( NC, TWO, DWORK(LETA), 1 ) + CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LALPHA), 1 ) +C +C Computation of lambda(k) and eta(k). +C + K = 1 +C +C WHILE ( K <= DA and HURWTZ = TRUE ) DO + 60 IF ( ( K.LE.DA ) .AND. HURWTZ ) THEN + NCK = NC - K + CALL DCOPY( NCK+1, DWORK(LALPHA), -1, DWORK(LRO), 1 ) + W = DWORK(LALPHA+NCK)/DWORK(LRO+NCK) + IF ( ABS( W ).GE.ONE ) HURWTZ = .FALSE. + IF ( HURWTZ ) THEN + DWORK(LAMBDA+K-1) = W + CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LALPHA), 1 ) + W = DWORK(LETA+NCK)/DWORK(LALPHA) + DWORK(LETA+NCK) = W + CALL DAXPY( NCK-1, -W, DWORK(LALPHA+1), -1, + $ DWORK(LETA+1), 1 ) + K = K + 1 + END IF + GO TO 60 + END IF +C END WHILE 60 +C +C HURWTZ = The polynomial q is a Hurwitz polynomial. +C i-1 + IF ( HURWTZ ) THEN + CALL DCOPY( NC, DWORK(LQ), 1, E, 1 ) +C +C Accuracy test. +C + CALL SB08NY( DA, E, DWORK(LQ), TOLQ ) + CALL DAXPY( NC, -ONE, A, 1, DWORK(LQ), 1 ) + RES = ABS( DWORK( IDAMAX( NC, DWORK(LQ), 1 ) + LQ - 1 ) ) + CONV = ( RES.LT.TOLQ ) .OR. ( RES0.LT.ZERO ) +C + IF ( .NOT.CONV ) THEN + DWORK(LETA) = HALF*DWORK(LETA)/DWORK(LALPHA) +C +C Computation of x and q . +C i i +C DWORK(LETA,...,LETA+DA) : eta(k,0),...,eta(k,n) +C (LRO,...,LRO+DA-K+1) : eta(k,n-k+1),...,eta(k,0) +C + DO 80 K = DA, 1, -1 + NCK = NC - K + 1 + CALL DCOPY( NCK, DWORK(LETA), -1, DWORK(LRO), 1 ) + W = DWORK(LAMBDA+K-1) + CALL DAXPY( NCK, -W, DWORK(LRO), 1, DWORK(LETA), 1 ) + 80 CONTINUE +C + S = ZERO +C + DO 100 J = 0, DA + W = HALF*( DWORK(LETA+J) + E(J+1) ) + DWORK(LQ+J) = W + S = S + W**2 + 100 CONTINUE +C + RES0 = S - A0 +C +C Test on the monotonicity of q . +C 0 + CONV = DWORK(LQ).GT.E(1) + GO TO 40 + END IF + END IF + END IF +C END WHILE 40 +C +C Reverse the order of the coefficients in the array E. +C + CALL DSWAP( NC, E, 1, DWORK, -1 ) + CALL DSWAP( NC, DWORK, 1, E, 1 ) +C + IF ( .NOT.CONV ) THEN + IF ( HURWTZ ) THEN + INFO = 3 + ELSE IF ( I.EQ.1 ) THEN + INFO = 2 + ELSE + INFO = 4 + END IF + END IF +C + RETURN +C *** Last line of SB08ND *** + END diff --git a/mex/sources/libslicot/SB08NY.f b/mex/sources/libslicot/SB08NY.f new file mode 100644 index 000000000..f6c0cb668 --- /dev/null +++ b/mex/sources/libslicot/SB08NY.f @@ -0,0 +1,83 @@ + SUBROUTINE SB08NY( DA, A, B, EPSB ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the coefficients of B(z) = A(1/z) * A(z) and a norm for +C the accuracy of the computed coefficients. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C DA (input) INTEGER +C The degree of the polynomials A(z) and B(z). DA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (DA+1) +C This array must contain the coefficients of the polynomial +C A(z) in increasing powers of z. +C +C B (output) DOUBLE PRECISION array, dimension (DA+1) +C This array contains the coefficients of the polynomial +C B(z). +C +C EPSB (output) DOUBLE PRECISION +C A value used for checking the accuracy of the computed +C coefficients. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB08BZ by A.J. Geurts. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Laplace transform, polynomial operations, spectral factorization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION THREE + PARAMETER ( THREE = 3.0D0 ) +C .. Scalar Arguments .. + INTEGER DA + DOUBLE PRECISION EPSB +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*) +C .. Local Scalars .. + INTEGER I +C .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH +C .. Executable Statements .. +C + DO 20 I = 1, DA + 1 + B(I) = DDOT( DA-I+2, A(1), 1, A(I), 1 ) + 20 CONTINUE +C + EPSB = THREE*DLAMCH( 'Epsilon' )*B(1) +C + RETURN +C *** Last line of SB08NY *** + END diff --git a/mex/sources/libslicot/SB09MD.f b/mex/sources/libslicot/SB09MD.f new file mode 100644 index 000000000..edb0e2d1a --- /dev/null +++ b/mex/sources/libslicot/SB09MD.f @@ -0,0 +1,251 @@ + SUBROUTINE SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, + $ LDSE, PRE, LDPRE, TOL, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compare two multivariable sequences M1(k) and M2(k) for +C k = 1,2,...,N, and evaluate their closeness. Each of the +C parameters M1(k) and M2(k) is an NC by NB matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of parameters. N >= 0. +C +C NC (input) INTEGER +C The number of rows in M1(k) and M2(k). NC >= 0. +C +C NB (input) INTEGER +C The number of columns in M1(k) and M2(k). NB >= 0. +C +C H1 (input) DOUBLE PRECISION array, dimension (LDH1,N*NB) +C The leading NC-by-N*NB part of this array must contain +C the multivariable sequence M1(k), where k = 1,2,...,N. +C Each parameter M1(k) is an NC-by-NB matrix, whose +C (i,j)-th element must be stored in H1(i,(k-1)*NB+j) for +C i = 1,2,...,NC and j = 1,2,...,NB. +C +C LDH1 INTEGER +C The leading dimension of array H1. LDH1 >= MAX(1,NC). +C +C H2 (input) DOUBLE PRECISION array, dimension (LDH2,N*NB) +C The leading NC-by-N*NB part of this array must contain +C the multivariable sequence M2(k), where k = 1,2,...,N. +C Each parameter M2(k) is an NC-by-NB matrix, whose +C (i,j)-th element must be stored in H2(i,(k-1)*NB+j) for +C i = 1,2,...,NC and j = 1,2,...,NB. +C +C LDH2 INTEGER +C The leading dimension of array H2. LDH2 >= MAX(1,NC). +C +C SS (output) DOUBLE PRECISION array, dimension (LDSS,NB) +C The leading NC-by-NB part of this array contains the +C matrix SS. +C +C LDSS INTEGER +C The leading dimension of array SS. LDSS >= MAX(1,NC). +C +C SE (output) DOUBLE PRECISION array, dimension (LDSE,NB) +C The leading NC-by-NB part of this array contains the +C quadratic error matrix SE. +C +C LDSE INTEGER +C The leading dimension of array SE. LDSE >= MAX(1,NC). +C +C PRE (output) DOUBLE PRECISION array, dimension (LDPRE,NB) +C The leading NC-by-NB part of this array contains the +C percentage relative error matrix PRE. +C +C LDPRE INTEGER +C The leading dimension of array PRE. LDPRE >= MAX(1,NC). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in the computation of the error +C matrices SE and PRE. If the user sets TOL to be less than +C EPS then the tolerance is taken as EPS, where EPS is the +C machine precision (see LAPACK Library routine DLAMCH). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The (i,j)-th element of the matrix SS is defined by: +C N 2 +C SS = SUM M1 (k) . (1) +C ij k=1 ij +C +C The (i,j)-th element of the quadratic error matrix SE is defined +C by: +C N 2 +C SE = SUM (M1 (k) - M2 (k)) . (2) +C ij k=1 ij ij +C +C The (i,j)-th element of the percentage relative error matrix PRE +C is defined by: +C +C PRE = 100 x SQRT( SE / SS ). (3) +C ij ij ij +C +C The following precautions are taken by the routine to guard +C against underflow and overflow: +C +C (i) if ABS( M1 (k) ) > 1/TOL or ABS( M1 (k) - M2 (k) ) > 1/TOL, +C ij ij ij +C +C then SE and SS are set to 1/TOL and PRE is set to 1; and +C ij ij ij +C +C (ii) if ABS( SS ) <= TOL, then PRE is set to 100. +C ij ij +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately +C 2xNBxNCx(N+1) multiplications/divisions, +C 4xNBxNCxN additions/subtractions and +C NBxNC square roots. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997. +C Supersedes Release 2.0 routine SB09AD by S. Van Huffel, Katholieke +C University Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Closeness multivariable sequences, elementary matrix operations, +C real signals, system response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HUNDRD + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HUNDRD = 100.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDH1, LDH2, LDPRE, LDSE, LDSS, N, NB, NC + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION H1(LDH1,*), H2(LDH2,*), PRE(LDPRE,*), + $ SE(LDSE,*), SS(LDSS,*) +C .. Local Scalars .. + LOGICAL NOFLOW + INTEGER I, J, K + DOUBLE PRECISION EPSO, SSE, SSS, TOLER, VAR, VARE +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NC.LT.0 ) THEN + INFO = -2 + ELSE IF( NB.LT.0 ) THEN + INFO = -3 + ELSE IF( LDH1.LT.MAX( 1, NC ) ) THEN + INFO = -5 + ELSE IF( LDH2.LT.MAX( 1, NC ) ) THEN + INFO = -7 + ELSE IF( LDSS.LT.MAX( 1, NC ) ) THEN + INFO = -9 + ELSE IF( LDSE.LT.MAX( 1, NC ) ) THEN + INFO = -11 + ELSE IF( LDPRE.LT.MAX( 1, NC ) ) THEN + INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB09MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. NC.EQ.0 .OR. NB.EQ.0 ) + $ RETURN +C + TOLER = MAX( TOL, DLAMCH( 'Epsilon' ) ) + EPSO = ONE/TOLER +C + DO 60 J = 1, NB +C + DO 40 I = 1, NC + SSE = ZERO + SSS = ZERO + NOFLOW = .TRUE. + K = 0 +C +C WHILE ( ( NOFLOW .AND. ( K .LT. N*NB ) ) DO + 20 IF ( ( NOFLOW ) .AND. ( K.LT.N*NB ) ) THEN + VAR = H1(I,K+J) + VARE = H2(I,K+J) - VAR + IF ( ABS( VAR ).GT.EPSO .OR. ABS( VARE ).GT.EPSO ) + $ THEN + SE(I,J) = EPSO + SS(I,J) = EPSO + PRE(I,J) = ONE + NOFLOW = .FALSE. + ELSE + IF ( ABS( VARE ).GT.TOLER ) SSE = SSE + VARE*VARE + IF ( ABS( VAR ).GT.TOLER ) SSS = SSS + VAR*VAR + K = K + NB + END IF + GO TO 20 + END IF +C END WHILE 20 +C + IF ( NOFLOW ) THEN + SE(I,J) = SSE + SS(I,J) = SSS + PRE(I,J) = HUNDRD + IF ( SSS.GT.TOLER ) PRE(I,J) = SQRT( SSE/SSS )*HUNDRD + END IF + 40 CONTINUE +C + 60 CONTINUE +C + RETURN +C *** Last line of SB09MD *** + END diff --git a/mex/sources/libslicot/SB10AD.f b/mex/sources/libslicot/SB10AD.f new file mode 100644 index 000000000..a74b3a8ee --- /dev/null +++ b/mex/sources/libslicot/SB10AD.f @@ -0,0 +1,827 @@ + SUBROUTINE SB10AD( JOB, N, M, NP, NCON, NMEAS, GAMMA, A, LDA, + $ B, LDB, C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, + $ LDCK, DK, LDDK, AC, LDAC, BC, LDBC, CC, LDCC, + $ DC, LDDC, RCOND, GTOL, ACTOL, IWORK, LIWORK, + $ DWORK, LDWORK, BWORK, LBWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of an H-infinity optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C using modified Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for the estimated minimal possible value of gamma with respect +C to GTOL, where B2 has as column size the number of control inputs +C (NCON) and C2 has as row size the number of measurements (NMEAS) +C being provided to the controller, and then to compute the matrices +C of the closed-loop system +C +C | AC | BC | +C G = |----|----|, +C | CC | DC | +C +C if the stabilizing controller exists. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C ARGUMENTS +C +C Input/Output Parameters +C +C JOB (input) INTEGER +C Indicates the strategy for reducing the GAMMA value, as +C follows: +C = 1: Use bisection method for decreasing GAMMA from GAMMA +C to GAMMAMIN until the closed-loop system leaves +C stability. +C = 2: Scan from GAMMA to 0 trying to find the minimal GAMMA +C for which the closed-loop system retains stability. +C = 3: First bisection, then scanning. +C = 4: Find suboptimal controller only. +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input/output) DOUBLE PRECISION +C The initial value of gamma on input. It is assumed that +C gamma is sufficiently large so that the controller is +C admissible. GAMMA >= 0. +C On output it contains the minimal estimated gamma. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) +C The leading 2*N-by-2*N part of this array contains the +C closed-loop system state matrix AC. +C +C LDAC INTEGER +C The leading dimension of the array AC. +C LDAC >= max(1,2*N). +C +C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) +C The leading 2*N-by-(M-NCON) part of this array contains +C the closed-loop system input matrix BC. +C +C LDBC INTEGER +C The leading dimension of the array BC. +C LDBC >= max(1,2*N). +C +C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) +C The leading (NP-NMEAS)-by-2*N part of this array contains +C the closed-loop system output matrix CC. +C +C LDCC INTEGER +C The leading dimension of the array CC. +C LDCC >= max(1,NP-NMEAS). +C +C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) +C The leading (NP-NMEAS)-by-(M-NCON) part of this array +C contains the closed-loop system input/output matrix DC. +C +C LDDC INTEGER +C The leading dimension of the array DC. +C LDDC >= max(1,NP-NMEAS). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C For the last successful step: +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Tolerances +C +C GTOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of GAMMA +C and its distance to the estimated minimal possible +C value of GAMMA. +C If GTOL <= 0, then a default value equal to sqrt(EPS) +C is used, where EPS is the relative machine precision. +C +C ACTOL DOUBLE PRECISION +C Upper bound for the poles of the closed-loop system +C used for determining if it is stable. +C ACTOL <= 0 for stable systems. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C +C LIWORK INTEGER +C The dimension of the array IWORK. +C LIWORK >= max(2*max(N,M-NCON,NP-NMEAS,NCON,NMEAS),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C value of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= LW1 + max(1,LW2,LW3,LW4,LW5 + MAX(LW6,LW7)), +C where +C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2; +C LW2 = max( ( N + NP1 + 1 )*( N + M2 ) + +C max( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), +C ( N + NP2 )*( N + M1 + 1 ) + +C max( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), +C M2 + NP1*NP1 + max( NP1*max( N, M1 ), +C 3*M2 + NP1, 5*M2 ), +C NP2 + M1*M1 + max( max( N, NP1 )*M1, +C 3*NP2 + M1, 5*NP2 ) ); +C LW3 = max( ND1*M1 + max( 4*min( ND1, M1 ) + max( ND1,M1 ), +C 6*min( ND1, M1 ) ), +C NP1*ND2 + max( 4*min( NP1, ND2 ) + +C max( NP1,ND2 ), +C 6*min( NP1, ND2 ) ) ); +C LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; +C LW5 = 2*N*N + M*N + N*NP; +C LW6 = max( M*M + max( 2*M1, 3*N*N + +C max( N*M, 10*N*N + 12*N + 5 ) ), +C NP*NP + max( 2*NP1, 3*N*N + +C max( N*NP, 10*N*N + 12*N + 5 ) )); +C LW7 = M2*NP2 + NP2*NP2 + M2*M2 + +C max( ND1*ND1 + max( 2*ND1, ( ND1 + ND2 )*NP2 ), +C ND2*ND2 + max( 2*ND2, ND2*M2 ), 3*N, +C N*( 2*NP2 + M2 ) + +C max( 2*N*M2, M2*NP2 + +C max( M2*M2 + 3*M2, NP2*( 2*NP2 + +C M2 + max( NP2, N ) ) ) ) ); +C M1 = M - M2, NP1 = NP - NP2, +C ND1 = NP1 - M2, ND2 = M1 - NP2. +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (LBWORK) +C +C LBWORK INTEGER +C The dimension of the array BWORK. LBWORK >= 2*N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A-j*omega*I B2 | had not full +C | C1 D12 | +C column rank in respect to the tolerance EPS; +C = 2: if the matrix | A-j*omega*I B1 | had not full row +C | C2 D21 | +C rank in respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance SQRT(EPS); +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance SQRT(EPS); +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21); +C |C1 D12| |C2 D21| +C = 6: if the controller is not admissible (too small value +C of gamma); +C = 7: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is +C zero [3]; +C = 10: if there are numerical problems when estimating +C singular values of D1111, D1112, D1111', D1121'; +C = 11: if the matrices Inp2 - D22*DK or Im2 - DK*D22 +C are singular to working precision; +C = 12: if a stabilizing controller cannot be found. +C +C METHOD +C +C The routine implements the Glover's and Doyle's 1988 formulas [1], +C [2], modified to improve the efficiency as described in [3]. +C +C JOB = 1: It tries with a decreasing value of GAMMA, starting with +C the given, and with the newly obtained controller estimates of the +C closed-loop system. If it is stable, (i.e., max(eig(AC)) < ACTOL) +C the iterations can be continued until the given tolerance between +C GAMMA and the estimated GAMMAMIN is reached. Otherwise, in the +C next step GAMMA is increased. The step in the all next iterations +C is step = step/2. The closed-loop system is obtained by the +C formulas given in [2]. +C +C JOB = 2: The same as for JOB = 1, but with non-varying step till +C GAMMA = 0, step = max(0.1, GTOL). +C +C JOB = 3: Combines the JOB = 1 and JOB = 2 cases for a quicker +C procedure. +C +C JOB = 4: Suboptimal controller for current GAMMA only. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, MA, 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and on the condition numbers of +C the two Riccati equations, as given by the values of RCOND(1), +C RCOND(2), RCOND(3) and RCOND(4), respectively. +C This approach by estimating the closed-loop system and checking +C its poles seems to be reliable. +C +C CONTRIBUTORS +C +C A. Markovski, P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, +C July 2003. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, P1, THOUS + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ P1 = 0.1D+0, THOUS = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, JOB, LBWORK, LDA, LDAC, LDAK, LDB, LDBC, + $ LDBK, LDC, LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, + $ LIWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION ACTOL, GAMMA, GTOL +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), + $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), + $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), + $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), + $ DWORK( * ), RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER I, INF, INFO2, INFO3, IWAC, IWC, IWD, IWD1, + $ IWF, IWH, IWRE, IWRK, IWS1, IWS2, IWTU, IWTY, + $ IWWI, IWWR, IWX, IWY, LW1, LW2, LW3, LW4, LW5, + $ LW6, LW7, LWAMAX, M1, M11, M2, MINWRK, MODE, + $ NP1, NP11, NP2 + DOUBLE PRECISION GAMABS, GAMAMN, GAMAMX, GTOLL, MINEAC, STEPG, + $ TOL2 +C .. +C .. External Functions .. + LOGICAL SELECT + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DGESVD, DLACPY, SB10LD, SB10PD, SB10QD, + $ SB10RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN, SQRT +C .. +C .. Executable Statements .. +C +C Decode and test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS + NP11 = NP1 - M2 + M11 = M1 - NP2 +C + INFO = 0 + IF ( JOB.LT.1 .OR. JOB.GT.4 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( NP.LT.0 ) THEN + INFO = -4 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -5 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -6 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -15 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -19 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -21 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -23 + ELSE IF( LDAC.LT.MAX( 1, 2*N ) ) THEN + INFO = -25 + ELSE IF( LDBC.LT.MAX( 1, 2*N ) ) THEN + INFO = -27 + ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN + INFO = -29 + ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN + INFO = -31 + ELSE +C +C Compute workspace. +C + LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 + LW2 = MAX( ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), + $ ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), + $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, + $ 5*M2 ), + $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, + $ 5*NP2 ) ) + LW3 = MAX( NP11*M1 + MAX( 4*MIN( NP11, M1 ) + MAX( NP11, M1 ), + $ 6*MIN( NP11, M1 ) ), + $ NP1*M11 + MAX( 4*MIN( NP1, M11 ) + MAX( NP1, M11 ), + $ 6*MIN( NP1, M11 ) ) ) + LW4 = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP + LW5 = 2*N*N + M*N + N*NP + LW6 = MAX( M*M + MAX( 2*M1, 3*N*N + + $ MAX( N*M, 10*N*N + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*N*N + + $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) + LW7 = M2*NP2 + NP2*NP2 + M2*M2 + + $ MAX( NP11*NP11 + MAX( 2*NP11, ( NP11 + M11 )*NP2 ), + $ M11*M11 + MAX( 2*M11, M11*M2 ), 3*N, + $ N*( 2*NP2 + M2 ) + + $ MAX( 2*N*M2, M2*NP2 + + $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + + $ M2 + MAX( NP2, N ) ) ) ) ) + MINWRK = LW1 + MAX( 1, LW2, LW3, LW4, LW5 + MAX( LW6, LW7 ) ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -38 + ELSE IF( LIWORK.LT.MAX( 2*MAX( N, M1, NP1, M2, NP2 ), + $ N*N ) ) THEN + INFO = -36 + ELSE IF( LBWORK.LT.2*N ) THEN + INFO = -40 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB10AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + MODE = JOB + IF ( MODE.GT.2 ) + $ MODE = 1 + GTOLL = GTOL + IF( GTOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for GAMMA. +C + GTOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage 1. +C + IWC = 1 + N*M + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) +C + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) +C + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the Hinf optimal controller. +C Workspace: need LW1 + MAX(1,LWP1,LWP2,LWP3,LWP4), +C prefer larger, +C where +C LW1 = N*M + NP*N + NP*M + M2*M2 + NP2*NP2 +C LWP1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), +C LWP2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), +C LWP3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), +C LWP4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), +C with M1 = M - M2 and NP1 = NP - NP2. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C LW1 + MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). +C + TOL2 = -ONE +C + CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), + $ M2, DWORK( IWTY ), NP2, RCOND, TOL2, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IF ( INFO2.NE.0 ) THEN + INFO = INFO2 + RETURN + END IF +C +C Workspace usage 2. +C + IWD1 = IWRK + IWS1 = IWD1 + NP11*M1 +C +C Check if GAMMA < max(sigma[D1111,D1112],sigma[D1111',D1121']). +C Workspace: need LW1 + MAX(1, LWS1, LWS2), +C prefer larger, +C where +C LWS1 = NP11*M1 + MAX(4*MIN(NP11,M1)+MAX(NP11,M1),6*MIN(NP11,M1)) +C LWS2 = NP1*M11 + MAX(4*MIN(NP1,M11)+MAX(NP1,M11),6*MIN(NP1,M11)) +C + INFO2 = 0 + INFO3 = 0 +C + IF ( NP11.NE.0 .AND. M1.NE.0 ) THEN + IWRK = IWS1 + MIN( NP11, M1 ) + CALL DLACPY( 'Full', NP11, M1, DWORK(IWD), LDD, DWORK(IWD1), + $ NP11 ) + CALL DGESVD( 'N', 'N', NP11, M1, DWORK(IWD1), NP11, + $ DWORK(IWS1), DWORK(IWS1), 1, DWORK(IWS1), 1, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) + ELSE + DWORK(IWS1) = ZERO + END IF +C + IWS2 = IWD1 + NP1*M11 + IF ( NP1.NE.0 .AND. M11.NE.0 ) THEN + IWRK = IWS2 + MIN( NP1, M11 ) + CALL DLACPY( 'Full', NP1, M11, DWORK(IWD), LDD, DWORK(IWD1), + $ NP1 ) + CALL DGESVD( 'N', 'N', NP1, M11, DWORK(IWD1), NP1, DWORK(IWS2), + $ DWORK(IWS2), 1, DWORK(IWS2), 1, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO3 ) + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) + ELSE + DWORK(IWS2) = ZERO + END IF +C + GAMAMN = MAX( DWORK(IWS1), DWORK(IWS2) ) +C + IF ( INFO2.GT.0 .OR. INFO3.GT.0 ) THEN + INFO = 10 + RETURN + ELSE IF ( GAMMA.LE.GAMAMN ) THEN + INFO = 6 + RETURN + END IF +C +C Workspace usage 3. +C + IWX = IWD1 + IWY = IWX + N*N + IWF = IWY + N*N + IWH = IWF + M*N + IWRK = IWH + N*NP + IWAC = IWD1 + IWWR = IWAC + 4*N*N + IWWI = IWWR + 2*N + IWRE = IWWI + 2*N +C +C Prepare some auxiliary variables for the gamma iteration. +C + STEPG = GAMMA - GAMAMN + GAMABS = GAMMA + GAMAMX = GAMMA + INF = 0 +C +C ############################################################### +C +C Begin the gamma iteration. +C + 10 CONTINUE + STEPG = STEPG/TWO +C +C Try to compute the state feedback and output injection +C matrices for the current GAMMA. +C + CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), + $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ BWORK, INFO2 ) +C + IF ( INFO2.NE.0 ) GOTO 30 +C +C Try to compute the Hinf suboptimal (yet) controller. +C + CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, + $ DWORK( IWTY ), NP2, DWORK( IWX ), N, DWORK( IWY ), + $ N, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) +C + IF ( INFO2.NE.0 ) GOTO 30 +C +C Compute the closed-loop system. +C Workspace: need LW1 + 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; +C prefer larger. +C + CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, + $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, + $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, + $ DWORK( IWD1 ), LDWORK-IWD1+1, INFO2 ) +C + IF ( INFO2.NE.0 ) GOTO 30 +C + LWAMAX = MAX( LWAMAX, INT( DWORK( IWD1 ) ) + IWD1 - 1 ) +C +C Compute the poles of the closed-loop system. +C Workspace: need LW1 + 4*N*N + 4*N + max(1,6*N); +C prefer larger. +C + CALL DLACPY( 'Full', 2*N, 2*N, AC, LDAC, DWORK(IWAC), 2*N ) +C + CALL DGEES( 'N', 'N', SELECT, 2*N, DWORK(IWAC), 2*N, IWORK, + $ DWORK(IWWR), DWORK(IWWI), DWORK(IWRE), 1, + $ DWORK(IWRE), LDWORK-IWRE+1, BWORK, INFO2 ) +C + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRE ) ) + IWRE - 1 ) +C +C Now DWORK(IWWR+I)=Re(Lambda), DWORK(IWWI+I)=Im(Lambda), +C for I=0,2*N-1. +C + MINEAC = -THOUS +C + DO 20 I = 0, 2*N - 1 + MINEAC = MAX( MINEAC, DWORK(IWWR+I) ) + 20 CONTINUE +C +C Check if the closed-loop system is stable. +C + 30 IF ( MODE.EQ.1 ) THEN + IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN + GAMABS = GAMMA + GAMMA = GAMMA - STEPG + INF = 1 + ELSE + GAMMA = MIN( GAMMA + STEPG, GAMAMX ) + END IF + ELSE IF ( MODE.EQ.2 ) THEN + IF ( INFO2.EQ.0 .AND. MINEAC.LT.ACTOL ) THEN + GAMABS = GAMMA + INF = 1 + END IF + GAMMA = GAMMA - MAX( P1, GTOLL ) + END IF +C +C More iterations? +C + IF ( MODE.EQ.1 .AND. JOB.EQ.3 .AND. TWO*STEPG.LT.GTOLL ) THEN + MODE = 2 + GAMMA = GAMABS + END IF +C + IF ( JOB.NE.4 .AND. + $ ( MODE.EQ.1 .AND. TWO*STEPG.GE.GTOLL .OR. + $ MODE.EQ.2 .AND. GAMMA.GT.ZERO ) ) THEN + GOTO 10 + END IF +C +C ############################################################### +C +C End of the gamma iteration - Return if no stabilizing controller +C was found. +C + IF ( INF.EQ.0 ) THEN + INFO = 12 + RETURN + END IF +C +C Now compute the state feedback and output injection matrices +C using GAMABS. +C + GAMMA = GAMABS +C +C Integer workspace: need max(2*max(N,M-NCON,NP-NMEAS),N*N). +C Workspace: need LW1P + +C max(1,M*M + max(2*M1,3*N*N + +C max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))); +C prefer larger, +C where LW1P = LW1 + 2*N*N + M*N + N*NP. +C An upper bound of the second term after LW1P is +C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). +C + CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), + $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ BWORK, INFO2 ) +C + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C + IF ( INFO2.GT.0 ) THEN + INFO = INFO2 + 5 + RETURN + END IF +C +C Compute the Hinf optimal controller. +C Integer workspace: need max(2*(max(NP,M)-M2-NP2,M2,N),NP2). +C Workspace: need LW1P + +C max(1, M2*NP2 + NP2*NP2 + M2*M2 + +C max(D1*D1 + max(2*D1, (D1+D2)*NP2), +C D2*D2 + max(2*D2, D2*M2), 3*N, +C N*(2*NP2 + M2) + +C max(2*N*M2, M2*NP2 + +C max(M2*M2+3*M2, NP2*(2*NP2+ +C M2+max(NP2,N)))))) +C where D1 = NP1 - M2 = NP11, D2 = M1 - NP2 = M11; +C prefer larger. +C An upper bound of the second term after LW1P is +C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). +C + CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C + IF( INFO2.EQ.1 ) THEN + INFO = 6 + RETURN + ELSE IF( INFO2.EQ.2 ) THEN + INFO = 9 + RETURN + END IF +C +C Integer workspace: need 2*max(NCON,NMEAS). +C Workspace: need 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP; +C prefer larger. +C + CALL SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, D, + $ LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, AC, + $ LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, DWORK, + $ LDWORK, INFO2 ) +C + IF( INFO2.GT.0 ) THEN + INFO = 11 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10AD *** + END diff --git a/mex/sources/libslicot/SB10DD.f b/mex/sources/libslicot/SB10DD.f new file mode 100644 index 000000000..b6a99f7b9 --- /dev/null +++ b/mex/sources/libslicot/SB10DD.f @@ -0,0 +1,1007 @@ + SUBROUTINE SB10DD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, + $ DK, LDDK, X, LDX, Z, LDZ, RCOND, TOL, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C for the discrete-time system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C j*Theta +C (A3) | A-e *I B2 | has full column rank for all +C | C1 D12 | +C +C 0 <= Theta < 2*Pi , +C +C j*Theta +C (A4) | A-e *I B1 | has full row rank for all +C | C2 D21 | +C +C 0 <= Theta < 2*Pi . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA > 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the matrix +C Z, solution of the Z-Riccati equation. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION array, dimension (8) +C RCOND contains estimates of the reciprocal condition +C numbers of the matrices which are to be inverted and +C estimates of the reciprocal condition numbers of the +C Riccati equations which have to be solved during the +C computation of the controller. (See the description of +C the algorithm in [2].) +C RCOND(1) contains the reciprocal condition number of the +C matrix R3; +C RCOND(2) contains the reciprocal condition number of the +C matrix R1 - R2'*inv(R3)*R2; +C RCOND(3) contains the reciprocal condition number of the +C matrix V21; +C RCOND(4) contains the reciprocal condition number of the +C matrix St3; +C RCOND(5) contains the reciprocal condition number of the +C matrix V12; +C RCOND(6) contains the reciprocal condition number of the +C matrix Im2 + DKHAT*D22 +C RCOND(7) contains the reciprocal condition number of the +C X-Riccati equation; +C RCOND(8) contains the reciprocal condition number of the +C Z-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used in neglecting the small singular values +C in rank determination. If TOL <= 0, then a default value +C equal to 1000*EPS is used, where EPS is the relative +C machine precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*max(M2,N),M,M2+NP2,N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(LW1,LW2,LW3,LW4), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)); +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)); +C LW3 = 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + 6*N + +C max(14*N+23,16*N,2*N+M,3*M); +C LW4 = 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + 6*N + +C N*(M+NP2) + max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C max((N+Q)*(N+Q+6),13*N*N + M*M + 2*Q*Q + N*(M+Q) + +C max(M*(M+7*N),2*Q*(8*N+M+2*Q)) + 6*N + +C max(14*N+23,16*N,2*N+max(M,2*Q),3*max(M,2*Q)). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C j*Theta +C = 1: if the matrix | A-e *I B2 | had not full +C | C1 D12 | +C column rank; +C j*Theta +C = 2: if the matrix | A-e *I B1 | had not full +C | C2 D21 | +C row rank; +C = 3: if the matrix D12 had not full column rank; +C = 4: if the matrix D21 had not full row rank; +C = 5: if the controller is not admissible (too small value +C of gamma); +C = 6: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 7: if the Z-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the matrix Im2 + DKHAT*D22 is singular. +C = 9: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C +C METHOD +C +C The routine implements the method presented in [1]. +C +C REFERENCES +C +C [1] Green, M. and Limebeer, D.J.N. +C Linear Robust Control. +C Prentice-Hall, Englewood Cliffs, NJ, 1995. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C With approaching the minimum value of gamma some of the matrices +C which are to be inverted tend to become ill-conditioned and +C the X- or Z-Riccati equation may also become ill-conditioned +C which may deteriorate the accuracy of the result. (The +C corresponding reciprocal condition numbers are given in +C the output array RCOND.) +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Sep. 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, discrete-time H-infinity optimal +C control, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, THOUSN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ THOUSN = 1.0D+3 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, LDX, LDZ, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA, TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( * ), X( LDX, * ), Z( LDZ, * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IR2, IR3, IS2, IS3, IWB, IWC, IWD, IWG, + $ IWH, IWI, IWL, IWQ, IWR, IWRK, IWS, IWT, IWU, + $ IWV, IWW, J, LWAMAX, M1, M2, MINWRK, NP1, NP2 + DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL +C +C .. External Functions + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGESVD, DGETRF, DGETRS, DLACPY, + $ DLASET, DPOCON, DPOTRF, DSCAL, DSWAP, DSYRK, + $ DSYTRF, DSYTRS, DTRCON, DTRSM, MA02AD, MB01RU, + $ MB01RX, SB02OD, SB02SD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LE.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -22 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE +C +C Compute workspace. +C + IWB = ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ) + IWC = ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ) + IWD = 13*N*N + 2*M*M + N*( 8*M + NP2 ) + M1*( M2 + NP2 ) + + $ 6*N + MAX( 14*N + 23, 16*N, 2*N + M, 3*M ) + IWG = 13*N*N + M*M + ( 8*N + M + M2 + 2*NP2 )*( M2 + NP2 ) + + $ 6*N + N*( M + NP2 ) + + $ MAX( 14*N + 23, 16*N, 2*N + M2 + NP2, 3*( M2 + NP2 ) ) + MINWRK = MAX( IWB, IWC, IWD, IWG ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -31 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10DD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + RCOND( 5 ) = ONE + RCOND( 6 ) = ONE + RCOND( 7 ) = ONE + RCOND( 8 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance in rank determination. +C + TOLL = THOUSN*DLAMCH( 'Epsilon' ) + END IF +C +C Workspace usage. +C + IWS = (N+NP1)*(N+M2) + 1 + IWRK = IWS + (N+M2) +C +C jTheta +C Determine if |A-e I B2 | has full column rank at +C | C1 D12| +C Theta = Pi/2 . +C Workspace: need (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)); +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP1 ) + CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( N+1 ), N+NP1 ) + CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, + $ DWORK( (N+NP1)*N+1 ), N+NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( (N+NP1)*N+N+1 ), N+NP1 ) + CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK, N+NP1, DWORK( IWS ), + $ DWORK, N+NP1, DWORK, N+M2, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+N+M2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Workspace usage. +C + IWS = (N+NP2)*(N+M1) + 1 + IWRK = IWS + (N+NP2) +C +C jTheta +C Determine if |A-e I B1 | has full row rank at +C | C2 D21| +C Theta = Pi/2 . +C Workspace: need (N+NP2)*(N+M1+1) + +C MAX(3*(N+NP2)+N+M1,5*(N+NP2)); +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( N+1 ), + $ N+NP2 ) + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( (N+NP2)*N+1 ), + $ N+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( (N+NP2)*N+N+1 ), N+NP2 ) + CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK, N+NP2, DWORK( IWS ), + $ DWORK, N+NP2, DWORK, N+M1, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+N+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWS = NP1*M2 + 1 + IWRK = IWS + M2 +C +C Determine if D12 has full column rank. +C Workspace: need (NP1+1)*M2 + MAX(3*M2+NP1,5*M2); +C prefer larger. +C + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, DWORK, NP1 ) + CALL DGESVD( 'N', 'N', NP1, M2, DWORK, NP1, DWORK( IWS ), DWORK, + $ NP1, DWORK, M2, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+M2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWS = NP2*M1 + 1 + IWRK = IWS + NP2 +C +C Determine if D21 has full row rank. +C Workspace: need NP2*(M1+1) + MAX(3*NP2+M1,5*NP2); +C prefer larger. +C + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, NP2 ) + CALL DGESVD( 'N', 'N', NP2, M1, DWORK, NP2, DWORK( IWS ), DWORK, + $ NP2, DWORK, M1, DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 9 + RETURN + END IF + IF( DWORK( IWS+NP2 ) / DWORK( IWS ).LE.TOLL ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWV = 1 + IWB = IWV + M*M + IWC = IWB + N*M1 + IWD = IWC + ( M2 + NP2 )*N + IWQ = IWD + ( M2 + NP2 )*M1 + IWL = IWQ + N*N + IWR = IWL + N*M + IWI = IWR + 2*N + IWH = IWI + 2*N + IWS = IWH + 2*N + IWT = IWS + ( 2*N + M )*( 2*N + M ) + IWU = IWT + ( 2*N + M )*2*N + IWRK = IWU + 4*N*N + IR2 = IWV + M1 + IR3 = IR2 + M*M1 +C +C Compute R0 = |D11'||D11 D12| -|gamma^2*Im1 0| . +C |D12'| | 0 0| +C + CALL DSYRK( 'Lower', 'Transpose', M, NP1, ONE, D, LDD, ZERO, + $ DWORK, M ) + DO 10 J = 1, M*M1, M + 1 + DWORK( J ) = DWORK( J ) - GAMMA*GAMMA + 10 CONTINUE +C +C Compute C1'*C1 . +C + CALL DSYRK( 'Lower', 'Transpose', N, NP1, ONE, C, LDC, ZERO, + $ DWORK( IWQ ), N ) +C +C Compute C1'*|D11 D12| . +C + CALL DGEMM( 'Transpose', 'NoTranspose', N, M, NP1, ONE, C, LDC, + $ D, LDD, ZERO, DWORK( IWL ), N ) +C +C Solution of the X-Riccati equation. +C Workspace: need 13*N*N + 2*M*M + N*(8*M+NP2) + M1*(M2+NP2) + +C 6*N + max(14*N+23,16*N,2*N+M,3*M); +C prefer larger. +C + CALL SB02OD( 'D', 'B', 'N', 'L', 'N', 'S', N, M, NP, A, LDA, B, + $ LDB, DWORK( IWQ ), N, DWORK, M, DWORK( IWL ), N, + $ RCOND2, X, LDX, DWORK( IWR ), DWORK( IWI ), + $ DWORK( IWH ), DWORK( IWS ), 2*N+M, DWORK( IWT ), + $ 2*N+M, DWORK( IWU ), 2*N, TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 6 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C Workspace: need 4*N*N + 2*M*M + N*(3*M+NP2) + M1*(M2+NP2) + +C max(5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWS = IWR + IWH = IWS + M*M + IWT = IWH + N*M + IWU = IWT + N*N + IWG = IWU + N*N + IWRK = IWG + N*N + CALL DLACPY( 'Lower', M, M, DWORK, M, DWORK( IWS ), M ) + CALL DSYTRF( 'Lower', M, DWORK( IWS ), M, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + CALL MA02AD( 'Full', N, M, B, LDB, DWORK( IWH ), M ) + CALL DSYTRS( 'Lower', M, N, DWORK( IWS ), M, IWORK, DWORK( IWH ), + $ M, INFO2 ) + CALL MB01RX( 'Left', 'Lower', 'NoTranspose', N, M, ZERO, ONE, + $ DWORK( IWG ), N, B, LDB, DWORK( IWH ), M, INFO2 ) + CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, A, LDA, DWORK( IWT ), N, + $ DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, X, + $ LDX, SEPD, RCOND( 7 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 7 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWRK = IWR +C +C Compute the lower triangle of |R1 R2'| = R0 + B'*X*B . +C |R2 R3 | +C + CALL MB01RU( 'Lower', 'Transpose', M, N, ONE, ONE, DWORK, M, + $ B, LDB, X, LDX, DWORK( IWRK ), M*N, INFO2 ) +C +C Compute the Cholesky factorization of R3, R3 = V12'*V12 . +C Note that V12' is stored. +C + ANORM = DLANSY( '1', 'Lower', M2, DWORK( IR3 ), M, DWORK( IWRK ) ) + CALL DPOTRF( 'Lower', M2, DWORK( IR3 ), M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Lower', M2, DWORK( IR3 ), M, ANORM, RCOND( 1 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 1 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C + CALL DTRCON( '1', 'Lower', 'NonUnit', M2, DWORK( IR3 ), M, + $ RCOND( 5 ), DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 5 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute R2 <- inv(V12')*R2 . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, M1, + $ ONE, DWORK( IR3 ), M, DWORK( IR2 ), M ) +C +C Compute -Nabla = R2'*inv(R3)*R2 - R1 . +C + CALL DSYRK( 'Lower', 'Transpose', M1, M2, ONE, DWORK( IR2 ), M, + $ -ONE, DWORK, M ) +C +C Compute the Cholesky factorization of -Nabla, -Nabla = V21t'*V21t. +C Note that V21t' is stored. +C + ANORM = DLANSY( '1', 'Lower', M1, DWORK, M, DWORK( IWRK ) ) + CALL DPOTRF( 'Lower', M1, DWORK, M, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Lower', M1, DWORK, M, ANORM, RCOND( 2 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 2 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C + CALL DTRCON( '1', 'Lower', 'NonUnit', M1, DWORK, M, RCOND( 3 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 3 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute X*A . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, X, LDX, + $ A, LDA, ZERO, DWORK( IWQ ), N ) +C +C Compute |L1| = |D11'|*C1 + B'*X*A . +C |L2| = |D12'| +C + CALL MA02AD( 'Full', N, M, DWORK( IWL ), N, DWORK( IWRK ), M ) + CALL DLACPY( 'Full', M, N, DWORK( IWRK ), M, DWORK( IWL ), M ) + CALL DGEMM( 'Transpose', 'NoTranspose', M, N, N, ONE, B, LDB, + $ DWORK( IWQ ), N, ONE, DWORK( IWL ), M ) +C +C Compute L2 <- inv(V12')*L2 . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M2, N, ONE, + $ DWORK( IR3 ), M, DWORK( IWL+M1 ), M ) +C +C Compute L_Nabla = L1 - R2'*inv(R3)*L2 . +C + CALL DGEMM( 'Transpose', 'NoTranspose', M1, N, M2, -ONE, + $ DWORK( IR2 ), M, DWORK( IWL+M1 ), M, ONE, + $ DWORK( IWL ), M ) +C +C Compute L_Nabla <- inv(V21t')*L_Nabla . +C + CALL DTRSM( 'Left', 'Lower', 'NoTranspose', 'NonUnit', M1, N, ONE, + $ DWORK, M, DWORK( IWL ), M ) +C +C Compute Bt1 = B1*inv(V21t) . +C + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IWB ), N ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', N, M1, ONE, + $ DWORK, M, DWORK( IWB ), N ) +C +C Compute At . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M1, ONE, + $ DWORK( IWB ), N, DWORK( IWL ), M, ONE, AK, LDAK ) +C +C Scale Bt1 . +C + CALL DSCAL( N*M1, GAMMA, DWORK( IWB ), 1 ) +C +C Compute |Dt11| = |R2 |*inv(V21t) . +C |Dt21| |D21| +C + CALL DLACPY( 'Full', M2, M1, DWORK( IR2 ), M, DWORK( IWD ), + $ M2+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, DWORK( IWD+M2 ), + $ M2+NP2 ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'NonUnit', M2+NP2, + $ M1, ONE, DWORK, M, DWORK( IWD ), M2+NP2 ) +C +C Compute Ct = |Ct1| = |L2| + |Dt11|*inv(V21t')*L_Nabla . +C |Ct2| = |C2| + |Dt21| +C + CALL DLACPY( 'Full', M2, N, DWORK( IWL+M1 ), M, DWORK( IWC ), + $ M2+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1 ), LDC, DWORK( IWC+M2 ), + $ M2+NP2 ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2+NP2, N, M1, ONE, + $ DWORK( IWD ), M2+NP2, DWORK( IWL ), M, ONE, + $ DWORK( IWC ), M2+NP2 ) +C +C Scale |Dt11| . +C |Dt21| +C + CALL DSCAL( ( M2+NP2 )*M1, GAMMA, DWORK( IWD ), 1 ) +C +C Workspace usage. +C + IWW = IWD + ( M2 + NP2 )*M1 + IWQ = IWW + ( M2 + NP2 )*( M2 + NP2 ) + IWL = IWQ + N*N + IWR = IWL + N*( M2 + NP2 ) + IWI = IWR + 2*N + IWH = IWI + 2*N + IWS = IWH + 2*N + IWT = IWS + ( 2*N + M2 + NP2 )*( 2*N + M2 + NP2 ) + IWU = IWT + ( 2*N + M2 + NP2 )*2*N + IWG = IWU + 4*N*N + IWRK = IWG + ( M2 + NP2 )*N + IS2 = IWW + ( M2 + NP2 )*M2 + IS3 = IS2 + M2 +C +C Compute S0 = |Dt11||Dt11' Dt21'| -|gamma^2*Im2 0| . +C |Dt21| | 0 0| +C + CALL DSYRK( 'Upper', 'NoTranspose', M2+NP2, M1, ONE, DWORK( IWD ), + $ M2+NP2, ZERO, DWORK( IWW ), M2+NP2 ) + DO 20 J = IWW, IWW - 1 + ( M2 + NP2 )*M2, M2 + NP2 + 1 + DWORK( J ) = DWORK( J ) - GAMMA*GAMMA + 20 CONTINUE +C +C Compute Bt1*Bt1' . +C + CALL DSYRK( 'Upper', 'NoTranspose', N, M1, ONE, DWORK( IWB ), N, + $ ZERO, DWORK( IWQ ), N ) +C +C Compute Bt1*|Dt11' Dt21'| . +C + CALL DGEMM( 'NoTranspose', 'Transpose', N, M2+NP2, M1, ONE, + $ DWORK( IWB ), N, DWORK( IWD ), M2+NP2, ZERO, + $ DWORK( IWL ), N ) +C +C Transpose At in situ (in AK) . +C + DO 30 J = 2, N + CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) + 30 CONTINUE +C +C Transpose Ct . +C + CALL MA02AD( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, + $ DWORK( IWG ), N ) +C +C Solution of the Z-Riccati equation. +C Workspace: need 13*N*N + M*M + (8*N+M+M2+2*NP2)*(M2+NP2) + +C N*(M+NP2) + 6*N + +C max(14*N+23,16*N,2*N+M2+NP2,3*(M2+NP2)); +C prefer larger. +C + CALL SB02OD( 'D', 'B', 'N', 'U', 'N', 'S', N, M2+NP2, NP, AK, + $ LDAK, DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWW ), + $ M2+NP2, DWORK( IWL ), N, RCOND2, Z, LDZ, DWORK( IWR), + $ DWORK( IWI ), DWORK( IWH ), DWORK( IWS ), 2*N+M2+NP2, + $ DWORK( IWT ), 2*N+M2+NP2, DWORK( IWU ), 2*N, TOLL, + $ IWORK, DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 7 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C Workspace: need 4*N*N + M*M + 2*(M2+NP2)*(M2+NP2)+ +C N*(M+2*M2+3*NP2) + (M2+NP2)*M1 + +C max(5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWS = IWR + IWH = IWS + ( M2 + NP2 )*( M2 + NP2 ) + IWT = IWH + N*( M2 + NP2 ) + IWU = IWT + N*N + IWG = IWU + N*N + IWRK = IWG + N*N + CALL DLACPY( 'Upper', M2+NP2, M2+NP2, DWORK( IWW ), M2+NP2, + $ DWORK( IWS ), M2+NP2 ) + CALL DSYTRF( 'Upper', M2+NP2, DWORK( IWS ), M2+NP2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + CALL DLACPY( 'Full', M2+NP2, N, DWORK( IWC ), M2+NP2, + $ DWORK( IWH ), M2+NP2 ) + CALL DSYTRS( 'Upper', M2+NP2, N, DWORK( IWS ), M2+NP2, IWORK, + $ DWORK( IWH ), M2+NP2, INFO2 ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', N, M2+NP2, ZERO, ONE, + $ DWORK( IWG ), N, DWORK( IWC ), M2+NP2, DWORK( IWH ), + $ M2+NP2, INFO2 ) + CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWT ), + $ N, DWORK( IWU ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Z, LDZ, SEPD, RCOND( 8 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 8 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IWRK = IWR +C +C Compute the upper triangle of +C |St1 St2| = S0 + |Ct1|*Z*|Ct1' Ct2'| . +C |St2' St3| |Ct2| +C + CALL MB01RU( 'Upper', 'NoTranspose', M2+NP2, N, ONE, ONE, + $ DWORK( IWW ), M2+NP2, DWORK( IWC ), M2+NP2, Z, LDZ, + $ DWORK( IWRK ), (M2+NP2)*N, INFO2 ) +C +C Compute the Cholesky factorization of St3, St3 = U12'*U12 . +C + ANORM = DLANSY( '1', 'Upper', NP2, DWORK( IS3 ), M2+NP2, + $ DWORK( IWRK ) ) + CALL DPOTRF( 'Upper', NP2, DWORK( IS3 ), M2+NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DPOCON( 'Upper', NP2, DWORK( IS3 ), M2+NP2, ANORM, + $ RCOND( 4 ), DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 4 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C +C Compute St2 <- St2*inv(U12) . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', M2, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) +C +C Check the negative definiteness of St1 - St2*inv(St3)*St2' . +C + CALL DSYRK( 'Upper', 'NoTranspose', M2, NP2, ONE, DWORK( IS2 ), + $ M2+NP2, -ONE, DWORK( IWW ), M2+NP2 ) + CALL DPOTRF( 'Upper', M2, DWORK( IWW ), M2+NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 5 + RETURN + END IF +C +C Restore At in situ . +C + DO 40 J = 2, N + CALL DSWAP( J-1, AK( J, 1 ), LDAK, AK( 1, J ), 1 ) + 40 CONTINUE +C +C Compute At*Z . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, AK, LDAK, + $ Z, LDZ, ZERO, DWORK( IWRK ), N ) +C +C Compute Mt2 = Bt1*Dt21' + At*Z*Ct2' in BK . +C + CALL DLACPY( 'Full', N, NP2, DWORK( IWL+N*M2 ), N, BK, LDBK ) + CALL DGEMM( 'NoTranspose', 'Transpose', N, NP2, N, ONE, + $ DWORK( IWRK ), N, DWORK( IWC+M2 ), M2+NP2, ONE, + $ BK, LDBK ) +C +C Compute St2 <- St2*inv(U12') . +C + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', M2, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, DWORK( IS2 ), M2+NP2 ) +C +C Compute DKHAT = -inv(V12)*St2 in DK . +C + CALL DLACPY( 'Full', M2, NP2, DWORK( IS2 ), M2+NP2, DK, LDDK ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, NP2, + $ -ONE, DWORK( IR3 ), M, DK, LDDK ) +C +C Compute CKHAT = -inv(V12)*(Ct1 - St2*inv(St3)*Ct2) in CK . +C + CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, N, NP2, -ONE, + $ DWORK( IS2 ), M2+NP2, DWORK( IWC+M2 ), M2+NP2, ONE, + $ CK, LDCK ) + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', M2, N, -ONE, + $ DWORK( IR3 ), M, CK, LDCK ) +C +C Compute Mt2*inv(St3) in BK . +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) + CALL DTRSM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, NP2, + $ ONE, DWORK( IS3 ), M2+NP2, BK, LDBK ) +C +C Compute AKHAT in AK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, ONE, + $ B( 1, M1+1 ), LDB, CK, LDCK, ONE, AK, LDAK ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, NP2, -ONE, BK, + $ LDBK, DWORK( IWC+M2 ), M2+NP2, ONE, AK, LDAK ) +C +C Compute BKHAT in BK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, ONE, + $ B( 1, M1+1 ), LDB, DK, LDDK, ONE, BK, LDBK ) +C +C Compute Im2 + DKHAT*D22 . +C + IWRK = M2*M2 + 1 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M2, M2, NP2, ONE, DK, + $ LDDK, D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 8 + RETURN + END IF + CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND( 6 ), DWORK( IWRK ), + $ IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 6 ).LT.TOLL ) THEN + INFO = 8 + RETURN + END IF +C +C Compute CK . +C + CALL DGETRS( 'NoTranspose', M2, N, DWORK, M2, IWORK, CK, LDCK, + $ INFO2 ) +C +C Compute DK . +C + CALL DGETRS( 'NoTranspose', M2, NP2, DWORK, M2, IWORK, DK, LDDK, + $ INFO2 ) +C +C Compute AK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M2, NP2, ONE, BK, + $ LDBK, D( NP1+1, M1+1 ), LDD, ZERO, DWORK, N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M2, -ONE, DWORK, + $ N, CK, LDCK, ONE, AK, LDAK ) +C +C Compute BK . +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, NP2, M2, -ONE, DWORK, + $ N, DK, LDDK, ONE, BK, LDBK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10DD *** + END diff --git a/mex/sources/libslicot/SB10ED.f b/mex/sources/libslicot/SB10ED.f new file mode 100644 index 000000000..51f7f048f --- /dev/null +++ b/mex/sources/libslicot/SB10ED.f @@ -0,0 +1,468 @@ + SUBROUTINE SB10ED( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal n-state controller +C +C | AK | BK | +C K = |----|----| +C | CK | DK | +C +C for the discrete-time system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| , +C | C1 | 0 D12 | | C | D | +C | C2 | D21 D22 | +C +C where B2 has as column size the number of control inputs (NCON) +C and C2 has as row size the number of measurements (NMEAS) being +C provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C j*Theta +C (A3) | A-e *I B2 | has full column rank for all +C | C1 D12 | +C +C 0 <= Theta < 2*Pi , +C +C +C j*Theta +C (A4) | A-e *I B1 | has full row rank for all +C | C2 D21 | +C +C 0 <= Theta < 2*Pi . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input/worksp.) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C This array is modified internally, but it is restored on +C exit. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION array, dimension (7) +C RCOND contains estimates the reciprocal condition +C numbers of the matrices which are to be inverted and the +C reciprocal condition numbers of the Riccati equations +C which have to be solved during the computation of the +C controller. (See the description of the algorithm in [2].) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix TU; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix TY; +C RCOND(3) contains the reciprocal condition number of the +C matrix Im2 + B2'*X2*B2; +C RCOND(4) contains the reciprocal condition number of the +C matrix Ip2 + C2*Y2*C2'; +C RCOND(5) contains the reciprocal condition number of the +C X-Riccati equation; +C RCOND(6) contains the reciprocal condition number of the +C Y-Riccati equation; +C RCOND(7) contains the reciprocal condition number of the +C matrix Im2 + DKHAT*D22 . +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the +C transformations applied for diagonalizing D12 and D21, +C and for checking the nonsingularity of the matrices to be +C inverted. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*M2,2*N,N*N,NP2) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + +C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), +C LW5 = 2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N),M2*(N+M2+ +C max(3,M1)),NP2*(N+NP2+3)), +C LW6 = max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2), +C with M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), +C 2*N*N+max(1,14*N*N+6*N+max(14*N+23,16*N), +C Q*(N+Q+max(Q,3)))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C j*Theta +C = 1: if the matrix | A-e *I B2 | had not full +C | C1 D12 | +C column rank in respect to the tolerance EPS; +C j*Theta +C = 2: if the matrix | A-e *I B1 | had not full +C | C2 D21 | +C row rank in respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A-I B2 |, |A-I B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C = 6: if the X-Riccati equation was not solved +C successfully; +C = 7: if the matrix Im2 + B2'*X2*B2 is not positive +C definite, or it is numerically singular (with +C respect to the tolerance TOL); +C = 8: if the Y-Riccati equation was not solved +C successfully; +C = 9: if the matrix Ip2 + C2*Y2*C2' is not positive +C definite, or it is numerically singular (with +C respect to the tolerance TOL); +C =10: if the matrix Im2 + DKHAT*D22 is singular, or its +C estimated condition number is larger than or equal +C to 1/TOL. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C matrices which are to be inverted and on the condition numbers of +C the matrix Riccati equations which are to be solved in the +C computation of the controller. (The corresponding reciprocal +C condition numbers are given in the output array RCOND.) +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Feb. 2000, Nov. 2005. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, optimal regulator, +C robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER I, INFO2, IWC, IWD, IWRK, IWTU, IWTY, IWX, IWY, + $ LW1, LW2, LW3, LW4, LW5, LW6, LWAMAX, M1, M2, + $ M2L, MINWRK, NL, NLP, NP1, NP2, NPL + DOUBLE PRECISION TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DLACPY, SB10PD, SB10SD, SB10TD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS + NL = MAX( 1, N ) + NPL = MAX( 1, NP ) + M2L = MAX( 1, M2 ) + NLP = MAX( 1, NP2 ) +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.NL ) THEN + INFO = -7 + ELSE IF( LDB.LT.NL ) THEN + INFO = -9 + ELSE IF( LDC.LT.NPL ) THEN + INFO = -11 + ELSE IF( LDD.LT.NPL ) THEN + INFO = -13 + ELSE IF( LDAK.LT.NL ) THEN + INFO = -15 + ELSE IF( LDBK.LT.NL ) THEN + INFO = -17 + ELSE IF( LDCK.LT.M2L ) THEN + INFO = -19 + ELSE IF( LDDK.LT.M2L ) THEN + INFO = -21 + ELSE +C +C Compute workspace. +C + LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, + $ 5*( N + M2 ) ) + LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + + $ M1, 5*( N + NP2 ) ) + LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) + LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) + LW5 = 2*N*N + MAX( 1, 14*N*N + + $ 6*N + MAX( 14*N + 23, 16*N ), + $ M2*( N + M2 + MAX( 3, M1 ) ), + $ NP2*( N + NP2 + 3 ) ) + LW6 = MAX( N*M2, N*NP2, M2*NP2, M2*M2 + 4*M2 ) + MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + + $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -26 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .AND. MAX( M2, NP2 ).EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + RCOND( 5 ) = ONE + RCOND( 6 ) = ONE + RCOND( 7 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for rank tests. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWC = N*M + 1 + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, NL ) + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NPL ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NPL ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the H2 optimal controller. +C Since SLICOT Library routine SB10PD performs the tests +C corresponding to the continuous-time counterparts of the +C assumptions (A3) and (A4), for the frequency w = 0, the +C next SB10PD routine call uses A - I. +C + DO 10 I = 1, N + A(I,I) = A(I,I) - ONE + 10 CONTINUE +C + CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, + $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, DWORK( IWTU ), + $ M2L, DWORK( IWTY ), NLP, RCOND, TOLL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + DO 20 I = 1, N + A(I,I) = A(I,I) + ONE + 20 CONTINUE +C + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IWX = IWRK + IWY = IWX + N*N + IWRK = IWY + N*N +C +C Compute the optimal H2 controller for the normalized system. +C + CALL SB10SD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, NL, + $ DWORK( IWC ), NPL, DWORK( IWD ), NPL, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, DWORK( IWX ), NL, + $ DWORK( IWY ), NL, RCOND( 3 ), TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + IWRK = IWX +C +C Compute the H2 optimal controller for the original system. +C + CALL SB10TD( N, M, NP, NCON, NMEAS, DWORK( IWD ), NPL, + $ DWORK( IWTU ), M2L, DWORK( IWTY ), NLP, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, RCOND( 7 ), TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 10 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10ED *** + END diff --git a/mex/sources/libslicot/SB10FD.f b/mex/sources/libslicot/SB10FD.f new file mode 100644 index 000000000..61fcdd4f3 --- /dev/null +++ b/mex/sources/libslicot/SB10FD.f @@ -0,0 +1,469 @@ + SUBROUTINE SB10FD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, + $ DK, LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, + $ BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal n-state +C controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C using modified Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank and D21 is full row rank, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations for computing the normalized form in +C SLICOT Library routine SB10PD. Transformation matrices +C whose reciprocal condition numbers are less than TOL are +C not allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK = max(2*max(N,M-NCON,NP-NMEAS,NCON),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + +C max(1,LW1,LW2,LW3,LW4,LW5,LW6), where +C LW1 = (N+NP1+1)*(N+M2) + max(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + max(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + max(NP1*max(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + max(max(N,NP1)*M1,3*NP2+M1,5*NP2), +C LW5 = 2*N*N + N*(M+NP) + +C max(1,M*M + max(2*M1,3*N*N+max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))), +C LW6 = 2*N*N + N*(M+NP) + +C max(1, M2*NP2 + NP2*NP2 + M2*M2 + +C max(D1*D1 + max(2*D1, (D1+D2)*NP2), +C D2*D2 + max(2*D2, D2*M2), 3*N, +C N*(2*NP2 + M2) + +C max(2*N*M2, M2*NP2 + +C max(M2*M2+3*M2, NP2*(2*NP2+ +C M2+max(NP2,N)))))), +C with D1 = NP1 - M2, D2 = M1 - NP2, +C NP1 = NP - NP2, M1 = M - M2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C 2*Q*(3*Q+2*N)+max(1,(N+Q)*(N+Q+6),Q*(Q+max(N,Q,5)+1), +C 2*N*(N+2*Q)+max(1,4*Q*Q+ +C max(2*Q,3*N*N+max(2*N*Q,10*N*N+12*N+5)), +C Q*(3*N+3*Q+max(2*N,4*Q+max(N,Q))))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A-j*omega*I B2 | had not full +C | C1 D12 | +C column rank in respect to the tolerance EPS; +C = 2: if the matrix | A-j*omega*I B1 | had not full row +C | C2 D21 | +C rank in respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C = 6: if the controller is not admissible (too small value +C of gamma); +C = 7: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 8: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 9: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is +C zero [3]. +C +C METHOD +C +C The routine implements the Glover's and Doyle's 1988 formulas [1], +C [2] modified to improve the efficiency as described in [3]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and on the condition numbers of +C the two Riccati equations, as given by the values of RCOND(1), +C RCOND(2), RCOND(3) and RCOND(4), respectively. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA, TOL +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, + $ IWX, IWY, LW1, LW2, LW3, LW4, LW5, LW6, + $ LWAMAX, M1, M2, MINWRK, ND1, ND2, NP1, NP2 + DOUBLE PRECISION TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DLACPY, SB10PD, SB10QD, SB10RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + LW1 = ( N + NP1 + 1 )*( N + M2 ) + MAX( 3*( N + M2 ) + N + NP1, + $ 5*( N + M2 ) ) + LW2 = ( N + NP2 )*( N + M1 + 1 ) + MAX( 3*( N + NP2 ) + N + + $ M1, 5*( N + NP2 ) ) + LW3 = M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, 5*M2 ) + LW4 = NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, 5*NP2 ) + LW5 = 2*N*N + N*( M + NP ) + + $ MAX( 1, M*M + MAX( 2*M1, 3*N*N + + $ MAX( N*M, 10*N*N + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*N*N + + $ MAX( N*NP, 10*N*N + 12*N + 5 ) ) ) + LW6 = 2*N*N + N*( M + NP ) + + $ MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + + $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), + $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, + $ N*( 2*NP2 + M2 ) + + $ MAX( 2*N*M2, M2*NP2 + + $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + + $ M2 + MAX( NP2, N ) ) ) ) ) ) + MINWRK = N*M + NP*( N + M ) + M2*M2 + NP2*NP2 + + $ MAX( 1, LW1, LW2, LW3, LW4, LW5, LW6 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -27 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10FD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWC = 1 + N*M + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the Hinf (sub)optimal controller. +C + CALL SB10PD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWTU ), + $ M2, DWORK( IWTY ), NP2, RCOND, TOLL, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IWX = IWRK + IWY = IWX + N*N + IWF = IWY + N*N + IWH = IWF + M*N + IWRK = IWH + N*NP +C +C Compute the (sub)optimal state feedback and output injection +C matrices. +C + CALL SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWX ), N, DWORK( IWY ), + $ N, RCOND(3), IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + 5 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute the Hinf (sub)optimal controller. +C + CALL SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), + $ M, DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, DWORK( IWX ), N, DWORK( IWY ), N, AK, LDAK, BK, + $ LDBK, CK, LDCK, DK, LDDK, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.EQ.1 ) THEN + INFO = 6 + RETURN + ELSE IF( INFO2.EQ.2 ) THEN + INFO = 9 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10FD *** + END diff --git a/mex/sources/libslicot/SB10HD.f b/mex/sources/libslicot/SB10HD.f new file mode 100644 index 000000000..5e350a98c --- /dev/null +++ b/mex/sources/libslicot/SB10HD.f @@ -0,0 +1,390 @@ + SUBROUTINE SB10HD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal n-state controller +C +C | AK | BK | +C K = |----|----| +C | CK | DK | +C +C for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| , +C | C1 | 0 D12 | | C | D | +C | C2 | D21 D22 | +C +C where B2 has as column size the number of control inputs (NCON) +C and C2 has as row size the number of measurements (NMEAS) being +C provided to the controller. +c +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) The block D11 of D is zero, +C +C (A3) D12 is full column rank and D21 is full row rank. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations for computing the normalized form in +C SLICOT Library routine SB10UD. Transformation matrices +C whose reciprocal condition numbers are less than TOL are +C not allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*N,N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= N*M + NP*(N+M) + M2*M2 + NP2*NP2 + +C max(max(M2 + NP1*NP1 + +C max(NP1*N,3*M2+NP1,5*M2), +C NP2 + M1*M1 + +C max(M1*N,3*NP2+M1,5*NP2), +C N*M2,NP2*N,NP2*M2,1), +C N*(14*N+12+M2+NP2)+5), +C where M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C 2*Q*(3*Q+2*N)+max(1,Q*(Q+max(N,5)+1),N*(14*N+12+2*Q)+5). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 2: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 3: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices D12 or D21). +C = 4: if the X-Riccati equation was not solved +C successfully; +C = 5: if the Y-Riccati equation was not solved +C successfully. +C +C METHOD +C +C The routine implements the formulas given in [1], [2]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and on the condition numbers of +C the two Riccati equations, as given by the values of RCOND(1), +C RCOND(2), RCOND(3) and RCOND(4), respectively. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, Oct. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Jan. 2000, Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, optimal regulator, +C robust control. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWC, IWD, IWF, IWH, IWRK, IWTU, IWTY, + $ IWY, LWAMAX, M1, M2, MINWRK, NP1, NP2 + DOUBLE PRECISION TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DLACPY, SB10UD, SB10VD, SB10WD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -21 + ELSE +C +C Compute workspace. +C + MINWRK = N*M + NP*(N+M) + M2*M2 + NP2*NP2 + + $ MAX( MAX( M2 + NP1*NP1 + + $ MAX( NP1*N, 3*M2 + NP1, 5*M2 ), + $ NP2 + M1*M1 + + $ MAX( M1*N, 3*NP2 + M1, 5*NP2 ), + $ N*M2, NP2*N, NP2*M2, 1 ), + $ N*( 14*N + 12 + M2 + NP2 ) + 5 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -26 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10HD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for rank tests. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWC = N*M + 1 + IWD = IWC + NP*N + IWTU = IWD + NP*M + IWTY = IWTU + M2*M2 + IWRK = IWTY + NP2*NP2 +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWC ), NP ) + CALL DLACPY( 'Full', NP, M, D, LDD, DWORK( IWD ), NP ) +C +C Transform the system so that D12 and D21 satisfy the formulas +C in the computation of the H2 optimal controller. +C + CALL SB10UD( N, M, NP, NCON, NMEAS, DWORK, N, DWORK( IWC ), NP, + $ DWORK( IWD ), NP, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, RCOND, TOLL, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C + IWY = IWRK + IWF = IWY + N*N + IWH = IWF + M2*N + IWRK = IWH + N*NP2 +C +C Compute the optimal state feedback and output injection matrices. +C AK is used to store X. +C + CALL SB10VD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWF ), M2, DWORK( IWH ), N, + $ AK, LDAK, DWORK( IWY ), N, RCOND( 3 ), IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = INFO2 + 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute the H2 optimal controller. +C + CALL SB10WD( N, M, NP, NCON, NMEAS, A, LDA, DWORK, N, + $ DWORK( IWC ), NP, DWORK( IWD ), NP, DWORK( IWF ), M2, + $ DWORK( IWH ), N, DWORK( IWTU ), M2, DWORK( IWTY ), + $ NP2, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO2 ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10HD *** + END diff --git a/mex/sources/libslicot/SB10ID.f b/mex/sources/libslicot/SB10ID.f new file mode 100644 index 000000000..2ea302e96 --- /dev/null +++ b/mex/sources/libslicot/SB10ID.f @@ -0,0 +1,584 @@ + SUBROUTINE SB10ID( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, + $ FACTOR, NK, AK, LDAK, BK, LDBK, CK, LDCK, + $ DK, LDDK, RCOND, IWORK, DWORK, LDWORK, BWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the positive feedback controller +C +C | Ak | Bk | +C K = |----|----| +C | Ck | Dk | +C +C for the shaped plant +C +C | A | B | +C G = |---|---| +C | C | D | +C +C in the McFarlane/Glover Loop Shaping Design Procedure. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the plant. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A of the shaped plant. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B of the shaped plant. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C of the shaped plant. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system matrix D of the shaped plant. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C FACTOR (input) DOUBLE PRECISION +C = 1 implies that an optimal controller is required; +C > 1 implies that a suboptimal controller is required, +C achieving a performance FACTOR less than optimal. +C FACTOR >= 1. +C +C NK (output) INTEGER +C The order of the positive feedback controller. NK <= N. +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading NK-by-NK part of this array contains the +C controller state matrix Ak. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) +C The leading NK-by-NP part of this array contains the +C controller input matrix Bk. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading M-by-NK part of this array contains the +C controller output matrix Ck. +C +C LDCK INTEGER +C The leading dimension of the array CK. LDCK >= max(1,M). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) +C The leading M-by-NP part of this array contains the +C controller matrix Dk. +C +C LDDK INTEGER +C The leading dimension of the array DK. LDDK >= max(1,M). +C +C RCOND (output) DOUBLE PRECISION array, dimension (2) +C RCOND(1) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C RCOND(2) contains an estimate of the reciprocal condition +C number of the Z-Riccati equation. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*N,N*N,M,NP) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + +C max( 6*N*N + 5 + max(1,4*N*N+8*N), N*NP + 2*N ). +C For good performance, LDWORK must generally be larger. +C An upper bound of LDWORK in the above formula is +C LDWORK >= 10*N*N + M*M + NP*NP + 2*M*N + 2*N*NP + 4*N + +C 5 + max(1,4*N*N+8*N). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the X-Riccati equation is not solved successfully; +C = 2: the Z-Riccati equation is not solved successfully; +C = 3: the iteration to compute eigenvalues or singular +C values failed to converge; +C = 4: the matrix Ip - D*Dk is singular; +C = 5: the matrix Im - Dk*D is singular; +C = 6: the closed-loop system is unstable. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] McFarlane, D. and Glover, K. +C A loop shaping design procedure using H_infinity synthesis. +C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, +C 1992. +C +C NUMERICAL ASPECTS +C +C The accuracy of the results depends on the conditioning of the +C two Riccati equations solved in the controller design (see the +C output parameter RCOND). +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, +C Feb. 2001. +C +C KEYWORDS +C +C H_infinity control, Loop-shaping design, Robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NK, NP + DOUBLE PRECISION FACTOR +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + LOGICAL BWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 2 ) +C .. +C .. Local Scalars .. + CHARACTER*1 HINV + INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, + $ I11, I12, I13, INFO2, IWRK, J, LWA, LWAMAX, + $ MINWRK, N2, NS, SDIM + DOUBLE PRECISION SEP, FERR, GAMMA +C .. +C .. External Functions .. + LOGICAL SELECT + EXTERNAL SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEES, DGEMM, DLACPY, DLASET, DPOTRF, DPOTRS, + $ DSYRK, DTRSM, MB02VD, SB02RD, SB10JD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( FACTOR.LT.ONE ) THEN + INFO = -12 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN + INFO = -19 + ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN + INFO = -21 + END IF +C +C Compute workspace. +C + MINWRK = 4*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + + $ MAX( 6*N*N + 5 + MAX( 1, 4*N*N + 8*N ), N*NP + 2*N ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -25 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10ID', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C +C Workspace usage. +C + I1 = N*N + I2 = I1 + N*N + I3 = I2 + M*N + I4 = I3 + M*N + I5 = I4 + M*M + I6 = I5 + NP*NP + I7 = I6 + NP*N + I8 = I7 + N*N + I9 = I8 + N*N + I10 = I9 + N*N + I11 = I10 + N*N + I12 = I11 + 2*N + I13 = I12 + 2*N +C + IWRK = I13 + 4*N*N +C +C Compute D'*C . +C + CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, + $ DWORK( I2+1 ), M ) +C +C Compute S = Im + D'*D . +C + CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I4+1 ), M ) + CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I4+1 ), M ) +C +C Factorize S, S = T'*T, with T upper triangular. +C + CALL DPOTRF( 'U', M, DWORK( I4+1 ), M, INFO2 ) +C +C -1 +C Compute S D'*C . +C + CALL DPOTRS( 'U', M, N, DWORK( I4+1 ), M, DWORK( I2+1 ), M, + $ INFO2 ) +C +C -1 +C Compute B*T . +C + CALL DLACPY( 'F', N, M, B, LDB, DWORK( I3+1 ), N ) + CALL DTRSM( 'R', 'U', 'N', 'N', N, M, ONE, DWORK( I4+1 ), M, + $ DWORK( I3+1 ), N ) +C +C Compute R = Ip + D*D' . +C + CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I5+1 ), NP ) + CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I5+1 ), NP ) +C +C Factorize R, R = U'*U, with U upper triangular. +C + CALL DPOTRF( 'U', NP, DWORK( I5+1 ), NP, INFO2 ) +C +C -T +C Compute U C . +C + CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I6+1 ), NP ) + CALL DTRSM( 'L', 'U', 'T', 'N', NP, N, ONE, DWORK( I5+1 ), NP, + $ DWORK( I6+1 ), NP ) +C +C -1 +C Compute Ar = A - B*S D'*C . +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N ) + CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK( I2+1 ), M, + $ ONE, DWORK( I7+1 ), N ) +C +C -1 +C Compute the upper triangle of Cr = C'*R *C . +C + CALL DSYRK( 'U', 'T', N, NP, ONE, DWORK( I6+1 ), NP, ZERO, + $ DWORK( I8+1 ), N ) +C +C -1 +C Compute the upper triangle of Dr = B*S B' . +C + CALL DSYRK( 'U', 'N', N, M, ONE, DWORK( I3+1 ), N, ZERO, + $ DWORK( I9+1 ), N ) +C +C Solution of the Riccati equation Ar'*X + X*Ar + Cr - X*Dr*X = 0 . +C Workspace: need 10*N*N + M*M + NP*NP + 2*M*N + N*NP + 4*N + +C 5 + max(1,4*N*N+8*N). +C prefer larger. +C AK is used as workspace. +C + N2 = 2*N + CALL SB02RD( 'A', 'C', HINV, 'N', 'U', 'G', 'S', 'N', 'O', N, + $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, + $ DWORK( I9+1 ), N, DWORK( I8+1 ), N, DWORK, N, SEP, + $ RCOND( 1 ), FERR, DWORK( I11+1 ), DWORK( I12+1 ), + $ DWORK( I13+1 ), N2, IWORK, DWORK( IWRK+1 ), + $ LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( MINWRK, LWA ) +C +C Solution of the Riccati equation Ar*Z + Z*Ar' + Dr - Z*Cr*Z = 0 . +C + CALL SB02RD( 'A', 'C', HINV, 'T', 'U', 'G', 'S', 'N', 'O', N, + $ DWORK( I7+1 ), N, DWORK( I10+1 ), N, AK, LDAK, + $ DWORK( I8+1 ), N, DWORK( I9+1 ), N, DWORK( I1+1 ), + $ N, SEP, RCOND( 2 ), FERR, DWORK( I11+1 ), + $ DWORK( I12+1 ), DWORK( I13+1 ), N2, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 2 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C -1 -1 +C Compute F1 = -( S D'*C + S B'*X ) . +C + CALL DTRSM( 'R', 'U', 'T', 'N', N, M, ONE, DWORK( I4+1 ), M, + $ DWORK( I3+1 ), N ) + CALL DGEMM( 'T', 'N', M, N, N, -ONE, DWORK( I3+1 ), N, DWORK, N, + $ -ONE, DWORK( I2+1 ), M ) +C +C Compute gamma . +C + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK, N, DWORK( I1+1 ), N, + $ ZERO, DWORK( I7+1 ), N ) + CALL DGEES( 'N', 'N', SELECT, N, DWORK( I7+1 ), N, SDIM, + $ DWORK( I11+1 ), DWORK( I12+1 ), DWORK( IWRK+1 ), N, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) + GAMMA = ZERO + DO 10 I = 1, N + GAMMA = MAX( GAMMA, DWORK( I11+I ) ) + 10 CONTINUE + GAMMA = FACTOR*SQRT( ONE + GAMMA ) +C +C Workspace usage. +C Workspace: need 4*N*N + M*N + N*NP. +C + I4 = I3 + N*N + I5 = I4 + N*N +C +C Compute Ac = A + B*F1 . +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I4+1 ), N ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, DWORK( I2+1 ), M, + $ ONE, DWORK( I4+1 ), N ) +C +C Compute W1' = (1-gamma^2)*In + Z*X . +C + CALL DLASET( 'F', N, N, ZERO, ONE-GAMMA*GAMMA, DWORK( I3+1 ), N ) + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, + $ ONE, DWORK( I3+1 ), N ) +C +C Compute Bcp = gamma^2*Z*C' . +C + CALL DGEMM( 'N', 'T', N, NP, N, GAMMA*GAMMA, DWORK( I1+1 ), N, C, + $ LDC, ZERO, BK, LDBK ) +C +C Compute C + D*F1 . +C + CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I5+1 ), NP ) + CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, DWORK( I2+1 ), M, + $ ONE, DWORK( I5+1 ), NP ) +C +C Compute Acp = W1'*Ac + gamma^2*Z*C'*(C+D*F1) . +C + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I3+1 ), N, + $ DWORK( I4+1 ), N, ZERO, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, BK, LDBK, + $ DWORK( I5+1 ), NP, ONE, AK, LDAK ) +C +C Compute Ccp = B'*X . +C + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK, N, ZERO, + $ CK, LDCK ) +C +C Set Dcp = -D' . +C + DO 30 I = 1, M + DO 20 J = 1, NP + DK( I, J ) = -D( J, I ) + 20 CONTINUE + 30 CONTINUE +C + IWRK = I4 +C +C Reduce the generalized state-space description to a regular one. +C Workspace: need 3*N*N + M*N. +C Additional workspace: need 2*N*N + 2*N + N*MAX(5,N+M+NP). +C prefer larger. +C + CALL SB10JD( N, NP, M, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ DWORK( I3+1 ), N, NK, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Workspace usage. +C Workspace: need 4*N*N + M*M + NP*NP + 2*M*N + 2*N*NP. +C (NK <= N.) +C + I2 = NP*NP + I3 = I2 + NK*NP + I4 = I3 + M*M + I5 = I4 + N*M + I6 = I5 + NP*NK + I7 = I6 + M*N +C + IWRK = I7 + ( N + NK )*( N + NK ) +C +C Compute Ip - D*Dk . +C + CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) + CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, + $ DWORK, NP ) +C +C -1 +C Compute Bk*(Ip-D*Dk) . +C + CALL DLACPY( 'F', NK, NP, BK, LDBK, DWORK( I2+1 ), NK ) + CALL MB02VD( 'N', NK, NP, DWORK, NP, IWORK, DWORK( I2+1 ), NK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF +C +C Compute Im - Dk*D . +C + CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3+1 ), M ) + CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, + $ DWORK( I3+1 ), M ) +C +C -1 +C Compute B*(Im-Dk*D) . +C + CALL DLACPY( 'F', N, M, B, LDB, DWORK( I4+1 ), N ) + CALL MB02VD( 'N', N, M, DWORK( I3+1 ), M, IWORK, DWORK( I4+1 ), N, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF +C +C Compute D*Ck . +C + CALL DGEMM( 'N', 'N', NP, NK, M, ONE, D, LDD, CK, LDCK, ZERO, + $ DWORK( I5+1 ), NP ) +C +C Compute Dk*C . +C + CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, + $ DWORK( I6+1 ), M ) +C +C Compute the closed-loop state matrix. +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7+1 ), N+NK ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4+1 ), N, + $ DWORK( I6+1 ), M, ONE, DWORK( I7+1 ), N+NK ) + CALL DGEMM( 'N', 'N', NK, N, NP, ONE, DWORK( I2+1 ), NK, C, LDC, + $ ZERO, DWORK( I7+N+1 ), N+NK ) + CALL DGEMM( 'N', 'N', N, NK, M, ONE, DWORK( I4+1 ), N, CK, LDCK, + $ ZERO, DWORK( I7+(N+NK)*N+1 ), N+NK ) + CALL DLACPY( 'F', NK, NK, AK, LDAK, DWORK( I7+(N+NK)*N+N+1 ), + $ N+NK ) + CALL DGEMM( 'N', 'N', NK, NK, NP, ONE, DWORK( I2+1 ), NK, + $ DWORK( I5+1 ), NP, ONE, DWORK( I7+(N+NK)*N+N+1 ), + $ N+NK ) +C +C Compute the closed-loop poles. +C Additional workspace: need 3*(N+NK); prefer larger. +C The fact that M > 0, NP > 0, and NK <= N is used here. +C + CALL DGEES( 'N', 'N', SELECT, N+NK, DWORK( I7+1 ), N+NK, SDIM, + $ DWORK, DWORK( N+NK+1 ), DWORK( IWRK+1 ), N, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Check the stability of the closed-loop system. +C + NS = 0 + DO 40 I = 1, N+NK + IF( DWORK( I ).GE.ZERO ) NS = NS + 1 + 40 CONTINUE + IF( NS.GT.0 ) THEN + INFO = 6 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10ID *** + END diff --git a/mex/sources/libslicot/SB10JD.f b/mex/sources/libslicot/SB10JD.f new file mode 100644 index 000000000..938b65088 --- /dev/null +++ b/mex/sources/libslicot/SB10JD.f @@ -0,0 +1,355 @@ + SUBROUTINE SB10JD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, E, + $ LDE, NSYS, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To convert the descriptor state-space system +C +C E*dx/dt = A*x + B*u +C y = C*x + D*u +C +C into regular state-space form +C +C dx/dt = Ad*x + Bd*u +C y = Cd*x + Dd*u . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the descriptor system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state matrix A of the descriptor system. +C On exit, the leading NSYS-by-NSYS part of this array +C contains the state matrix Ad of the converted system. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B of the descriptor system. +C On exit, the leading NSYS-by-M part of this array +C contains the input matrix Bd of the converted system. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading NP-by-N part of this array must +C contain the output matrix C of the descriptor system. +C On exit, the leading NP-by-NSYS part of this array +C contains the output matrix Cd of the converted system. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading NP-by-M part of this array must +C contain the matrix D of the descriptor system. +C On exit, the leading NP-by-M part of this array contains +C the matrix Dd of the converted system. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the matrix E of the descriptor system. +C On exit, this array contains no useful information. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= max(1,N). +C +C NSYS (output) INTEGER +C The order of the converted state-space system. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max( 1, 2*N*N + 2*N + N*MAX( 5, N + M + NP ) ). +C For good performance, LDWORK must generally be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the iteration for computing singular value +C decomposition did not converge. +C +C METHOD +C +C The routine performs the transformations described in [1]. +C +C REFERENCES +C +C [1] Chiang, R.Y. and Safonov, M.G. +C Robust Control Toolbox User's Guide. +C The MathWorks Inc., Natick, Mass., 1992. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000, +C Feb. 2001. +C +C KEYWORDS +C +C Descriptor systems, state-space models. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDE, LDWORK, M, N, + $ NP, NSYS +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), E( LDE, * ) +C .. +C .. Local Scalars .. + INTEGER I, IA12, IA21, IB2, IC2, INFO2, IS, ISA, IU, + $ IV, IWRK, J, K, LWA, LWAMAX, MINWRK, NS1 + DOUBLE PRECISION EPS, SCALE, TOL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, DLACPY, DLASET, DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF +C +C Compute workspace. +C + MINWRK = MAX( 1, 2*N*( N + 1 ) + N*MAX( 5, N + M + NP ) ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -16 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + NSYS = 0 + DWORK( 1 ) = ONE + RETURN + END IF +C +C Set tol. +C + EPS = DLAMCH( 'Epsilon' ) + TOL = SQRT( EPS ) +C +C Workspace usage. +C + IS = 0 + IU = IS + N + IV = IU + N*N +C + IWRK = IV + N*N +C +C Compute the SVD of E. +C Additional workspace: need 5*N; prefer larger. +C + CALL DGESVD( 'S', 'S', N, N, E, LDE, DWORK( IS+1 ), DWORK( IU+1 ), + $ N, DWORK( IV+1 ), N, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( MINWRK, INT( DWORK( IWRK+1 ) + IWRK ) ) +C +C Determine the rank of E. +C + NS1 = 0 + DO 10 I = 1, N + IF( DWORK( IS+I ).GT.TOL ) NS1 = NS1 + 1 + 10 CONTINUE + IF( NS1.GT.0 ) THEN +C +C Transform A. +C Additional workspace: need N*max(N,M,NP). +C + CALL DGEMM( 'T', 'N', N, N, N, ONE, DWORK( IU+1 ), N, A, LDA, + $ ZERO, DWORK( IWRK+1 ), N ) + CALL DGEMM( 'N', 'T', N, N, N, ONE, DWORK( IWRK+1 ), N, + $ DWORK( IV+1 ), N, ZERO, A, LDA ) +C +C Transform B. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( IWRK+1 ), N ) + CALL DGEMM( 'T', 'N', N, M, N, ONE, DWORK( IU+1 ), N, + $ DWORK( IWRK+1 ), N, ZERO, B, LDB ) +C +C Transform C. +C + CALL DLACPY( 'Full', NP, N, C, LDC, DWORK( IWRK+1 ), NP ) + CALL DGEMM( 'N', 'T', NP, N, N, ONE, DWORK( IWRK+1 ), NP, + $ DWORK( IV+1 ), N, ZERO, C, LDC ) +C + K = N - NS1 + IF( K.GT.0 ) THEN + ISA = IU + K*K + IV = ISA + K + IWRK = IV + K*MAX( K, NS1 ) +C +C Compute the SVD of A22. +C Additional workspace: need 5*K; prefer larger. +C + CALL DGESVD( 'S', 'S', K, K, A( NS1+1, NS1+1 ), LDA, + $ DWORK( ISA+1 ), DWORK( IU+1 ), K, + $ DWORK( IV+1 ), K, DWORK( IWRK+1 ), LDWORK-IWRK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + IA12 = IWRK + IB2 = IA12 + NS1*K + IC2 = IB2 + K*M +C + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX, IC2 + K*NP ) +C +C Compute the transformed A12. +C + CALL DGEMM( 'N', 'T', NS1, K, K, ONE, A( 1, NS1+1 ), LDA, + $ DWORK( IV+1 ), K, ZERO, DWORK( IA12+1 ), NS1 ) +C +C Compute CC2. +C + CALL DGEMM( 'N', 'T', NP, K, K, ONE, C( 1, NS1+1 ), LDC, + $ DWORK( IV+1 ), K, ZERO, DWORK( IC2+1 ), NP ) +C +C Compute the transformed A21. +C + IA21 = IV + CALL DGEMM( 'T', 'N', K, NS1, K, ONE, DWORK( IU+1 ), K, + $ A( NS1+1, 1 ), LDA, ZERO, DWORK( IA21+1 ), K ) +C +C Compute BB2. +C + CALL DGEMM( 'T', 'N', K, M, K, ONE, DWORK( IU+1 ), K, + $ B( NS1+1, 1 ), LDB, ZERO, DWORK( IB2+1 ), K ) +C +C Compute A12*pinv(A22) and CC2*pinv(A22). +C + DO 20 J = 1, K + SCALE = ZERO + IF( DWORK( ISA+J ).GT.TOL ) SCALE = ONE/DWORK( ISA+J ) + CALL DSCAL( NS1, SCALE, DWORK( IA12+(J-1)*NS1+1 ), 1 ) + CALL DSCAL( NP, SCALE, DWORK( IC2+(J-1)*NP+1 ), 1 ) + 20 CONTINUE +C +C Compute Ad. +C + CALL DGEMM( 'N', 'N', NS1, NS1, K, -ONE, DWORK( IA12+1 ), + $ NS1, DWORK( IA21+1 ), K, ONE, A, LDA ) +C +C Compute Bd. +C + CALL DGEMM( 'N', 'N', NS1, M, K, -ONE, DWORK( IA12+1 ), NS1, + $ DWORK( IB2+1 ), K, ONE, B, LDB ) +C +C Compute Cd. +C + CALL DGEMM( 'N', 'N', NP, NS1, K, -ONE, DWORK( IC2+1 ), NP, + $ DWORK( IA21+1 ), K, ONE, C, LDC ) +C +C Compute Dd. +C + CALL DGEMM( 'N', 'N', NP, M, K, -ONE, DWORK( IC2+1 ), NP, + $ DWORK( IB2+1 ), K, ONE, D, LDD ) + END IF + DO 30 I = 1, NS1 + SCALE = ONE/SQRT( DWORK( IS+I ) ) + CALL DSCAL( NS1, SCALE, A( I, 1 ), LDA ) + CALL DSCAL( M, SCALE, B( I, 1 ), LDB ) + 30 CONTINUE + DO 40 J = 1, NS1 + SCALE = ONE/SQRT( DWORK( IS+J ) ) + CALL DSCAL( NS1, SCALE, A( 1, J ), 1 ) + CALL DSCAL( NP, SCALE, C( 1, J ), 1 ) + 40 CONTINUE + NSYS = NS1 + ELSE + CALL DLASET( 'F', N, N, ZERO, -ONE/EPS, A, LDA ) + CALL DLASET( 'F', N, M, ZERO, ZERO, B, LDB ) + CALL DLASET( 'F', NP, N, ZERO, ZERO, C, LDC ) + NSYS = N + END IF + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10JD *** + END diff --git a/mex/sources/libslicot/SB10KD.f b/mex/sources/libslicot/SB10KD.f new file mode 100644 index 000000000..38f1cef01 --- /dev/null +++ b/mex/sources/libslicot/SB10KD.f @@ -0,0 +1,650 @@ + SUBROUTINE SB10KD( N, M, NP, A, LDA, B, LDB, C, LDC, FACTOR, + $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, RCOND, + $ IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the positive feedback controller +C +C | Ak | Bk | +C K = |----|----| +C | Ck | Dk | +C +C for the shaped plant +C +C | A | B | +C G = |---|---| +C | C | 0 | +C +C in the Discrete-Time Loop Shaping Design Procedure. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the plant. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A of the shaped plant. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B of the shaped plant. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C of the shaped plant. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C FACTOR (input) DOUBLE PRECISION +C = 1 implies that an optimal controller is required; +C > 1 implies that a suboptimal controller is required +C achieving a performance FACTOR less than optimal. +C FACTOR >= 1. +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix Ak. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) +C The leading N-by-NP part of this array contains the +C controller input matrix Bk. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading M-by-N part of this array contains the +C controller output matrix Ck. +C +C LDCK INTEGER +C The leading dimension of the array CK. LDCK >= max(1,M). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) +C The leading M-by-NP part of this array contains the +C controller matrix Dk. +C +C LDDK INTEGER +C The leading dimension of the array DK. LDDK >= max(1,M). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND(1) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the P-Riccati equation is +C obtained; +C RCOND(2) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the Q-Riccati equation is +C obtained; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the X-Riccati equation is +C obtained; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the matrix Rx + Bx'*X*Bx (see the +C comments in the code). +C +C Workspace +C +C IWORK INTEGER array, dimension 2*max(N,NP+M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 15*N*N + 6*N + +C max( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + +C max( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + +C 4*M*NP + NP ). +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the P-Riccati equation is not solved successfully; +C = 2: the Q-Riccati equation is not solved successfully; +C = 3: the X-Riccati equation is not solved successfully; +C = 4: the iteration to compute eigenvalues failed to +C converge; +C = 5: the matrix Rx + Bx'*X*Bx is singular; +C = 6: the closed-loop system is unstable. +C +C METHOD +C +C The routine implements the method presented in [1]. +C +C REFERENCES +C +C [1] McFarlane, D. and Glover, K. +C A loop shaping design procedure using H_infinity synthesis. +C IEEE Trans. Automat. Control, vol. AC-37, no. 6, pp. 759-769, +C 1992. +C +C NUMERICAL ASPECTS +C +C The accuracy of the results depends on the conditioning of the +C two Riccati equations solved in the controller design. For +C better conditioning it is advised to take FACTOR > 1. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 2000. +C +C REVISIONS +C +C V. Sima, Katholieke University Leuven, January 2001, +C February 2001. +C +C KEYWORDS +C +C H_infinity control, Loop-shaping design, Robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDDK, + $ LDWORK, M, N, NP + DOUBLE PRECISION FACTOR +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + LOGICAL BWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ DK( LDDK, * ), DWORK( * ), RCOND( 4 ) +C .. +C .. Local Scalars .. + INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, + $ I11, I12, I13, I14, I15, I16, I17, I18, I19, + $ I20, I21, I22, I23, I24, I25, I26, INFO2, + $ IWRK, J, LWA, LWAMAX, MINWRK, N2, NS, SDIM + DOUBLE PRECISION GAMMA, RNORM +C .. +C .. External Functions .. + LOGICAL SELECT + DOUBLE PRECISION DLANSY, DLAPY2 + EXTERNAL DLANSY, DLAPY2, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGEES, DLACPY, DLASET, DPOTRF, DPOTRS, + $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, SB02OD, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( FACTOR.LT.ONE ) THEN + INFO = -10 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN + INFO = -18 + END IF +C +C Compute workspace. +C + MINWRK = 15*N*N + 6*N + MAX( 14*N+23, 16*N, 2*N+NP+M, 3*(NP+M) ) + + $ MAX( N*N, 11*N*NP + 2*M*M + 8*NP*NP + 8*M*N + + $ 4*M*NP + NP ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10KD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C +C Workspace usage. +C + N2 = 2*N + I1 = N*N + I2 = I1 + N*N + I3 = I2 + N*N + I4 = I3 + N*N + I5 = I4 + N2 + I6 = I5 + N2 + I7 = I6 + N2 + I8 = I7 + N2*N2 + I9 = I8 + N2*N2 +C + IWRK = I9 + N2*N2 + LWAMAX = 0 +C +C Compute Cr = C'*C . +C + CALL DSYRK( 'U', 'T', N, NP, ONE, C, LDC, ZERO, DWORK( I2+1 ), N ) +C +C Compute Dr = B*B' . +C + CALL DSYRK( 'U', 'N', N, M, ONE, B, LDB, ZERO, DWORK( I3+1 ), N ) +C -1 +C Solution of the Riccati equation A'*P*(In + Dr*P) *A - P + Cr = 0. +C + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, A, LDA, + $ DWORK( I3+1 ), N, DWORK( I2+1 ), N, DWORK, M, DWORK, + $ N, RCOND( 1 ), DWORK, N, DWORK( I4+1 ), + $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, + $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Transpose A in AK (used as workspace). +C + DO 40 J = 1, N + DO 30 I = 1, N + AK( I,J ) = A( J,I ) + 30 CONTINUE + 40 CONTINUE +C -1 +C Solution of the Riccati equation A*Q*(In + Cr*Q) *A' - Q + Dr = 0. +C + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, AK, LDAK, + $ DWORK( I2+1 ), N, DWORK( I3+1 ), N, DWORK, M, DWORK, + $ N, RCOND( 2 ), DWORK( I1+1 ), N, DWORK( I4+1 ), + $ DWORK( I5+1 ), DWORK( I6+1 ), DWORK( I7+1 ), N2, + $ DWORK( I8+1 ), N2, DWORK( I9+1 ), N2, -ONE, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 2 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Compute gamma. +C + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1+1 ), N, DWORK, N, + $ ZERO, AK, LDAK ) + CALL DGEES( 'N', 'N', SELECT, N, AK, LDAK, SDIM, DWORK( I6+1 ), + $ DWORK( I7+1 ), DWORK( IWRK+1 ), N, DWORK( IWRK+1 ), + $ LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) + GAMMA = ZERO + DO 50 I = 1, N + GAMMA = MAX( GAMMA, DWORK( I6+I ) ) + 50 CONTINUE + GAMMA = FACTOR*SQRT( ONE + GAMMA ) +C +C Workspace usage. +C + I3 = I2 + N*NP + I4 = I3 + NP*NP + I5 = I4 + NP*NP + I6 = I5 + NP*NP + I7 = I6 + NP + I8 = I7 + NP*NP + I9 = I8 + NP*NP + I10 = I9 + NP*NP + I11 = I10 + N*NP + I12 = I11 + N*NP + I13 = I12 + ( NP+M )*( NP+M ) + I14 = I13 + N*( NP+M ) + I15 = I14 + N*( NP+M ) + I16 = I15 + N*N + I17 = I16 + N2 + I18 = I17 + N2 + I19 = I18 + N2 + I20 = I19 + ( N2+NP+M )*( N2+NP+M ) + I21 = I20 + ( N2+NP+M )*N2 +C + IWRK = I21 + N2*N2 +C +C Compute Q*C' . +C + CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1+1 ), N, C, LDC, + $ ZERO, DWORK( I2+1 ), N ) +C +C Compute Ip + C*Q*C' . +C + CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I3+1 ), NP ) + CALL DGEMM( 'N', 'N', NP, NP, N, ONE, C, LDC, DWORK( I2+1 ), N, + $ ONE, DWORK( I3+1 ), NP ) +C +C Compute the eigenvalues and eigenvectors of Ip + C'*Q*C +C + CALL DLACPY( 'U', NP, NP, DWORK( I3+1 ), NP, DWORK( I5+1 ), NP ) + CALL DSYEV( 'V', 'U', NP, DWORK( I5+1 ), NP, DWORK( I6+1 ), + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C -1 +C Compute ( Ip + C'*Q*C ) . +C + DO 70 J = 1, NP + DO 60 I = 1, NP + DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / + $ DWORK( I6+I ) + 60 CONTINUE + 70 CONTINUE + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, + $ DWORK( I9+1 ), NP, ZERO, DWORK( I4+1 ), NP ) +C +C Compute Z2 . +C + DO 90 J = 1, NP + DO 80 I = 1, NP + DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP ) / + $ SQRT( DWORK( I6+I ) ) + 80 CONTINUE + 90 CONTINUE + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, + $ DWORK( I9+1 ), NP, ZERO, DWORK( I7+1 ), NP ) +C -1 +C Compute Z2 . +C + DO 110 J = 1, NP + DO 100 I = 1, NP + DWORK( I9+I+(J-1)*NP ) = DWORK( I5+J+(I-1)*NP )* + $ SQRT( DWORK( I6+I ) ) + 100 CONTINUE + 110 CONTINUE + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I5+1 ), NP, + $ DWORK( I9+1 ), NP, ZERO, DWORK( I8+1 ), NP ) +C +C Compute A*Q*C' . +C + CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, DWORK( I2+1 ), N, + $ ZERO, DWORK( I10+1 ), N ) +C -1 +C Compute H = -A*Q*C'*( Ip + C*Q*C' ) . +C + CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I10+1 ), N, + $ DWORK( I4+1 ), NP, ZERO, DWORK( I11+1 ), N ) +C +C Compute Rx . +C + CALL DLASET( 'F', NP+M, NP+M, ZERO, ONE, DWORK( I12+1 ), NP+M ) + DO 130 J = 1, NP + DO 120 I = 1, NP + DWORK( I12+I+(J-1)*(NP+M) ) = DWORK( I3+I+(J-1)*NP ) + 120 CONTINUE + DWORK( I12+J+(J-1)*(NP+M) ) = DWORK( I3+J+(J-1)*NP ) - + $ GAMMA*GAMMA + 130 CONTINUE +C +C Compute Bx . +C + CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I11+1 ), N, + $ DWORK( I8+1 ), NP, ZERO, DWORK( I13+1 ), N ) + DO 150 J = 1, M + DO 140 I = 1, N + DWORK( I13+N*NP+I+(J-1)*N ) = B( I, J ) + 140 CONTINUE + 150 CONTINUE +C +C Compute Sx . +C + CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I8+1 ), NP, + $ ZERO, DWORK( I14+1 ), N ) + CALL DLASET( 'F', N, M, ZERO, ZERO, DWORK( I14+N*NP+1 ), N ) +C +C Solve the Riccati equation +C -1 +C X = A'*X*A + Cx - (Sx + A'*X*Bx)*(Rx + Bx'*X*B ) *(Sx'+Bx'*X*A). +C + CALL SB02OD( 'D', 'B', 'C', 'U', 'N', 'S', N, NP+M, NP, A, LDA, + $ DWORK( I13+1 ), N, C, LDC, DWORK( I12+1 ), NP+M, + $ DWORK( I14+1 ), N, RCOND( 3 ), DWORK( I15+1 ), N, + $ DWORK( I16+1 ), DWORK( I17+1 ), DWORK( I18+1 ), + $ DWORK( I19+1 ), N2+NP+M, DWORK( I20+1 ), N2+NP+M, + $ DWORK( I21+1 ), N2, -ONE, IWORK, DWORK( IWRK+1 ), + $ LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C + I22 = I16 + I23 = I22 + ( NP+M )*N + I24 = I23 + ( NP+M )*( NP+M ) + I25 = I24 + ( NP+M )*N + I26 = I25 + M*N +C + IWRK = I25 +C +C Compute Bx'*X . +C + CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I13+1 ), N, + $ DWORK( I15+1 ), N, ZERO, DWORK( I22+1 ), NP+M ) +C +C Compute Rx + Bx'*X*Bx . +C + CALL DLACPY( 'F', NP+M, NP+M, DWORK( I12+1 ), NP+M, + $ DWORK( I23+1 ), NP+M ) + CALL DGEMM( 'N', 'N', NP+M, NP+M, N, ONE, DWORK( I22+1 ), NP+M, + $ DWORK( I13+1 ), N, ONE, DWORK( I23+1 ), NP+M ) +C +C Compute -( Sx' + Bx'*X*A ) . +C + DO 170 J = 1, N + DO 160 I = 1, NP+M + DWORK( I24+I+(J-1)*(NP+M) ) = DWORK( I14+J+(I-1)*N ) + 160 CONTINUE + 170 CONTINUE + CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I22+1 ), NP+M, + $ A, LDA, -ONE, DWORK( I24+1 ), NP+M ) +C +C Factorize Rx + Bx'*X*Bx . +C + RNORM = DLANSY( '1', 'U', NP+M, DWORK( I23+1 ), NP+M, + $ DWORK( IWRK+1 ) ) + CALL DSYTRF( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, + $ DWORK( IWRK+1 ), LDWORK-IWRK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) + CALL DSYCON( 'U', NP+M, DWORK( I23+1 ), NP+M, IWORK, RNORM, + $ RCOND( 4 ), DWORK( IWRK+1 ), IWORK( NP+M+1), INFO2 ) +C -1 +C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . +C + CALL DSYTRS( 'U', NP+M, N, DWORK( I23+1 ), NP+M, IWORK, + $ DWORK( I24+1 ), NP+M, INFO2 ) +C +C Compute B'*X . +C + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15+1 ), N, + $ ZERO, DWORK( I25+1 ), M ) +C +C Compute Im + B'*X*B . +C + CALL DLASET( 'F', M, M, ZERO, ONE, DWORK( I23+1 ), M ) + CALL DGEMM( 'N', 'N', M, M, N, ONE, DWORK( I25+1 ), M, B, LDB, + $ ONE, DWORK( I23+1 ), M ) +C +C Factorize Im + B'*X*B . +C + CALL DPOTRF( 'U', M, DWORK( I23+1 ), M, INFO2 ) +C -1 +C Compute ( Im + B'*X*B ) B'*X . +C + CALL DPOTRS( 'U', M, N, DWORK( I23+1 ), M, DWORK( I25+1 ), M, + $ INFO2 ) +C -1 +C Compute Dk = ( Im + B'*X*B ) B'*X*H . +C + CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I25+1 ), M, + $ DWORK( I11+1 ), N, ZERO, DK, LDDK ) +C +C Compute Bk = -H + B*Dk . +C + CALL DLACPY( 'F', N, NP, DWORK( I11+1 ), N, BK, LDBK ) + CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, -ONE, + $ BK, LDBK ) +C -1 +C Compute Dk*Z2 . +C + CALL DGEMM( 'N', 'N', M, NP, NP, ONE, DK, LDDK, DWORK( I8+1 ), + $ NP, ZERO, DWORK( I26+1 ), M ) +C +C Compute F1 + Z2*C . +C + CALL DLACPY( 'F', NP, N, DWORK( I24+1 ), NP+M, DWORK( I12+1 ), + $ NP ) + CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7+1 ), NP, C, LDC, + $ ONE, DWORK( I12+1 ), NP ) +C -1 +C Compute Ck = F2 - Dk*Z2 *( F1 + Z2*C ) . +C + CALL DLACPY( 'F', M, N, DWORK( I24+NP+1 ), NP+M, CK, LDCK ) + CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DWORK( I26+1 ), M, + $ DWORK( I12+1 ), NP, ONE, CK, LDCK ) +C +C Compute Ak = A + H*C + B*Ck . +C + CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I11+1 ), N, C, LDC, + $ ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ONE, AK, + $ LDAK ) +C +C Workspace usage. +C + I1 = M*N + I2 = I1 + N2*N2 + I3 = I2 + N2 +C + IWRK = I3 + N2 +C +C Compute Dk*C . +C + CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, + $ DWORK, M ) +C +C Compute the closed-loop state matrix. +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I1+1 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, DWORK, M, ONE, + $ DWORK( I1+1 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, NP, -ONE, BK, LDBK, C, LDC, ZERO, + $ DWORK( I1+N+1 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, ZERO, + $ DWORK( I1+N2*N+1 ), N2 ) + CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I1+N2*N+N+1 ), N2 ) +C +C Compute the closed-loop poles. +C + CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I1+1 ), N2, SDIM, + $ DWORK( I2+1 ), DWORK( I3+1 ), DWORK( IWRK+1 ), N, + $ DWORK( IWRK+1 ), LDWORK-IWRK, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF + LWA = INT( DWORK( IWRK+1 ) ) + IWRK + LWAMAX = MAX( LWA, LWAMAX ) +C +C Check the stability of the closed-loop system. +C + NS = 0 + DO 180 I = 1, N2 + IF( DLAPY2( DWORK( I2+I ), DWORK( I3+I ) ).GT.ONE ) NS = NS + 1 + 180 CONTINUE + IF( NS.GT.0 ) THEN + INFO = 6 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10KD *** + END diff --git a/mex/sources/libslicot/SB10LD.f b/mex/sources/libslicot/SB10LD.f new file mode 100644 index 000000000..b2d7d06b3 --- /dev/null +++ b/mex/sources/libslicot/SB10LD.f @@ -0,0 +1,438 @@ + SUBROUTINE SB10LD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the closed-loop system +C +C | AC | BC | +C G = |----|----|, +C | CC | DC | +C +C from the matrices of the open-loop system +C +C | A | B | +C P = |---|---| +C | C | D | +C +C and the matrices of the controller +C +C | AK | BK | +C K = |----|----|. +C | CK | DK | +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0. +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0. +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (input) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array must contain the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (input) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array must contain the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (input) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array must contain the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (input) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array must contain +C the controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C AC (output) DOUBLE PRECISION array, dimension (LDAC,2*N) +C The leading 2*N-by-2*N part of this array contains the +C closed-loop system state matrix AC. +C +C LDAC INTEGER +C The leading dimension of the array AC. +C LDAC >= max(1,2*N). +C +C BC (output) DOUBLE PRECISION array, dimension (LDBC,M-NCON) +C The leading 2*N-by-(M-NCON) part of this array contains +C the closed-loop system input matrix BC. +C +C LDBC INTEGER +C The leading dimension of the array BC. +C LDBC >= max(1,2*N). +C +C CC (output) DOUBLE PRECISION array, dimension (LDCC,2*N) +C The leading (NP-NMEAS)-by-2*N part of this array contains +C the closed-loop system output matrix CC. +C +C LDCC INTEGER +C The leading dimension of the array CC. +C LDCC >= max(1,NP-NMEAS). +C +C DC (output) DOUBLE PRECISION array, dimension (LDDC,M-NCON) +C The leading (NP-NMEAS)-by-(M-NCON) part of this array +C contains the closed-loop system input/output matrix DC. +C +C LDDC INTEGER +C The leading dimension of the array DC. +C LDDC >= max(1,NP-NMEAS). +C +C Workspace +C +C IWORK INTEGER array, dimension 2*max(NCON,NMEAS) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 2*M*M+NP*NP+2*M*N+M*NP+2*N*NP. +C For good performance, LDWORK must generally be larger. +C +C Error Indicactor +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix Inp2 - D22*DK is singular to working +C precision; +C = 2: if the matrix Im2 - DK*D22 is singular to working +C precision. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C matrices Inp2 - D22*DK and Im2 - DK*D22. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999. +C A. Markovski, Technical University, Sofia, April, 2003. +C +C KEYWORDS +C +C Closed loop systems, feedback control, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAC, LDAK, LDB, LDBC, LDBK, LDC, + $ LDCC, LDCK, LDD, LDDC, LDDK, LDWORK, M, N, + $ NCON, NMEAS, NP +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AC( LDAC, * ), AK( LDAK, * ), + $ B( LDB, * ), BC( LDBC, * ), BK( LDBK, * ), + $ C( LDC, * ), CC( LDCC, * ), CK( LDCK, * ), + $ D( LDD, * ), DC( LDDC, * ), DK( LDDK, * ), + $ DWORK( * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IW2, IW3, IW4, IW5, IW6, IW7, IW8, IWRK, + $ LWAMAX, M1, M2, MINWRK, N2, NP1, NP2 + DOUBLE PRECISION ANORM, EPS, RCOND +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DLACPY, DLASET, + $ XERBLA +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + N2 = 2*N + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -21 + ELSE IF( LDAC.LT.MAX( 1, N2 ) ) THEN + INFO = -23 + ELSE IF( LDBC.LT.MAX( 1, N2 ) ) THEN + INFO = -25 + ELSE IF( LDCC.LT.MAX( 1, NP1 ) ) THEN + INFO = -27 + ELSE IF( LDDC.LT.MAX( 1, NP1 ) ) THEN + INFO = -29 + ELSE +C +C Compute workspace. +C + MINWRK = 2*M*M + NP*NP + 2*M*N + M*NP + 2*N*NP + IF( LDWORK.LT.MINWRK ) + $ INFO = -32 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10LD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Workspace usage. +C + IW2 = NP2*NP2 + 1 + IW3 = IW2 + M2*M2 + IW4 = IW3 + NP2*N + IW5 = IW4 + M2*N + IW6 = IW5 + NP2*M1 + IW7 = IW6 + M2*M1 + IW8 = IW7 + M2*N + IWRK = IW8 + NP2*N +C +C Compute inv(Inp2 - D22*DK) . +C + CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK, NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, D( NP1+1, M1+1 ), + $ LDD, DK, LDDK, ONE, DWORK, NP2 ) + ANORM = DLANGE( '1', NP2, NP2, DWORK, NP2, DWORK( IWRK ) ) + CALL DGETRF( NP2, NP2, DWORK, NP2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGECON( '1', NP2, DWORK, NP2, ANORM, RCOND, DWORK( IWRK ), + $ IWORK( NP2+1 ), INFO ) + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF + CALL DGETRI( NP2, DWORK, NP2, IWORK, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute inv(Im2 - DK*D22) . +C + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) + CALL DGEMM( 'N', 'N', M2, M2, NP2, -ONE, DK, LDDK, + $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( M2+1 ), INFO ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 2 + RETURN + END IF + CALL DGETRI( M2, DWORK( IW2 ), M2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute inv(Inp2 - D22*DK)*C2 . +C + CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, DWORK, NP2, C( NP1+1, 1 ), + $ LDC, ZERO, DWORK( IW3 ), NP2 ) +C +C Compute DK*inv(Inp2 - D22*DK)*C2 . +C + CALL DGEMM( 'N', 'N', M2, N, NP2, ONE, DK, LDDK, DWORK( IW3 ), + $ NP2, ZERO, DWORK( IW4 ), M2 ) +C +C Compute inv(Inp2 - D22*DK)*D21 . +C + CALL DGEMM( 'N', 'N', NP2, M1, NP2, ONE, DWORK, NP2, + $ D( NP1+1, 1 ), LDD, ZERO, DWORK( IW5 ), NP2 ) +C +C Compute DK*inv(Inp2 - D22*DK)*D21 . +C + CALL DGEMM( 'N', 'N', M2, M1, NP2, ONE, DK, LDDK, DWORK( IW5 ), + $ NP2, ZERO, DWORK( IW6 ), M2 ) +C +C Compute inv(Im2 - DK*D22)*CK . +C + CALL DGEMM( 'N', 'N', M2, N, M2, ONE, DWORK( IW2 ), M2, CK, LDCK, + $ ZERO, DWORK( IW7 ), M2 ) +C +C Compute D22*inv(Im2 - DK*D22)*CK . +C + CALL DGEMM( 'N', 'N', NP2, N, M2, ONE, D( NP1+1, M1+1 ), LDD, + $ DWORK( IW7 ), M2, ZERO, DWORK( IW8 ), NP2 ) +C +C Compute AC . +C + CALL DLACPY( 'Full', N, N, A, LDA, AC, LDAC ) + CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, + $ DWORK( IW4 ), M2, ONE, AC, LDAC ) + CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, + $ DWORK( IW7 ), M2, ZERO, AC( 1, N+1 ), LDAC ) + CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW3 ), NP2, + $ ZERO, AC( N+1, 1 ), LDAC ) + CALL DLACPY( 'Full', N, N, AK, LDAK, AC( N+1, N+1 ), LDAC ) + CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, DWORK( IW8 ), NP2, + $ ONE, AC( N+1, N+1 ), LDAC ) +C +C Compute BC . +C + CALL DLACPY( 'Full', N, M1, B, LDB, BC, LDBC ) + CALL DGEMM( 'N', 'N', N, M1, M2, ONE, B( 1, M1+1 ), LDB, + $ DWORK( IW6 ), M2, ONE, BC, LDBC ) + CALL DGEMM( 'N', 'N', N, M1, NP2, ONE, BK, LDBK, DWORK( IW5 ), + $ NP2, ZERO, BC( N+1, 1 ), LDBC ) +C +C Compute CC . +C + CALL DLACPY( 'Full', NP1, N, C, LDC, CC, LDCC ) + CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, + $ DWORK( IW4 ), M2, ONE, CC, LDCC ) + CALL DGEMM( 'N', 'N', NP1, N, M2, ONE, D( 1, M1+1 ), LDD, + $ DWORK( IW7 ), M2, ZERO, CC( 1, N+1 ), LDCC ) +C +C Compute DC . +C + CALL DLACPY( 'Full', NP1, M1, D, LDD, DC, LDDC ) + CALL DGEMM( 'N', 'N', NP1, M1, M2, ONE, D( 1, M1+1 ), LDD, + $ DWORK( IW6 ), M2, ONE, DC, LDDC ) +C + RETURN +C *** Last line of SB10LD *** + END diff --git a/mex/sources/libslicot/SB10MD.f b/mex/sources/libslicot/SB10MD.f new file mode 100644 index 000000000..46ea3d84b --- /dev/null +++ b/mex/sources/libslicot/SB10MD.f @@ -0,0 +1,670 @@ + SUBROUTINE SB10MD( NC, MP, LENDAT, F, ORD, MNB, NBLOCK, ITYPE, + $ QUTOL, A, LDA, B, LDB, C, LDC, D, LDD, OMEGA, + $ TOTORD, AD, LDAD, BD, LDBD, CD, LDCD, DD, LDDD, + $ MJU, IWORK, LIWORK, DWORK, LDWORK, ZWORK, + $ LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To perform the D-step in the D-K iteration. It handles +C continuous-time case. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NC (input) INTEGER +C The order of the matrix A. NC >= 0. +C +C MP (input) INTEGER +C The order of the matrix D. MP >= 0. +C +C LENDAT (input) INTEGER +C The length of the vector OMEGA. LENDAT >= 2. +C +C F (input) INTEGER +C The number of the measurements and controls, i.e., +C the size of the block I_f in the D-scaling system. +C F >= 0. +C +C ORD (input/output) INTEGER +C The MAX order of EACH block in the fitting procedure. +C ORD <= LENDAT-1. +C On exit, if ORD < 1 then ORD = 1. +C +C MNB (input) INTEGER +C The number of diagonal blocks in the block structure of +C the uncertainty, and the length of the vectors NBLOCK +C and ITYPE. 1 <= MNB <= MP. +C +C NBLOCK (input) INTEGER array, dimension (MNB) +C The vector of length MNB containing the block structure +C of the uncertainty. NBLOCK(I), I = 1:MNB, is the size of +C each block. +C +C ITYPE (input) INTEGER array, dimension (MNB) +C The vector of length MNB indicating the type of each +C block. +C For I = 1 : MNB, +C ITYPE(I) = 1 indicates that the corresponding block is a +C real block. IN THIS CASE ONLY MJU(JW) WILL BE ESTIMATED +C CORRECTLY, BUT NOT D(S)! +C ITYPE(I) = 2 indicates that the corresponding block is a +C complex block. THIS IS THE ONLY ALLOWED VALUE NOW! +C NBLOCK(I) must be equal to 1 if ITYPE(I) is equal to 1. +C +C QUTOL (input) DOUBLE PRECISION +C The acceptable mean relative error between the D(jw) and +C the frequency responce of the estimated block +C [ADi,BDi;CDi,DDi]. When it is reached, the result is +C taken as good enough. +C A good value is QUTOL = 2.0. +C If QUTOL < 0 then only mju(jw) is being estimated, +C not D(s). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,NC) +C On entry, the leading NC-by-NC part of this array must +C contain the A matrix of the closed-loop system. +C On exit, if MP > 0, the leading NC-by-NC part of this +C array contains an upper Hessenberg matrix similar to A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,NC). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,MP) +C On entry, the leading NC-by-MP part of this array must +C contain the B matrix of the closed-loop system. +C On exit, the leading NC-by-MP part of this array contains +C the transformed B matrix corresponding to the Hessenberg +C form of A. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,NC). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,NC) +C On entry, the leading MP-by-NC part of this array must +C contain the C matrix of the closed-loop system. +C On exit, the leading MP-by-NC part of this array contains +C the transformed C matrix corresponding to the Hessenberg +C form of A. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,MP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,MP) +C The leading MP-by-MP part of this array must contain the +C D matrix of the closed-loop system. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,MP). +C +C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) +C The vector with the frequencies. +C +C TOTORD (output) INTEGER +C The TOTAL order of the D-scaling system. +C TOTORD is set to zero, if QUTOL < 0. +C +C AD (output) DOUBLE PRECISION array, dimension (LDAD,MP*ORD) +C The leading TOTORD-by-TOTORD part of this array contains +C the A matrix of the D-scaling system. +C Not referenced if QUTOL < 0. +C +C LDAD INTEGER +C The leading dimension of the array AD. +C LDAD >= MAX(1,MP*ORD), if QUTOL >= 0; +C LDAD >= 1, if QUTOL < 0. +C +C BD (output) DOUBLE PRECISION array, dimension (LDBD,MP+F) +C The leading TOTORD-by-(MP+F) part of this array contains +C the B matrix of the D-scaling system. +C Not referenced if QUTOL < 0. +C +C LDBD INTEGER +C The leading dimension of the array BD. +C LDBD >= MAX(1,MP*ORD), if QUTOL >= 0; +C LDBD >= 1, if QUTOL < 0. +C +C CD (output) DOUBLE PRECISION array, dimension (LDCD,MP*ORD) +C The leading (MP+F)-by-TOTORD part of this array contains +C the C matrix of the D-scaling system. +C Not referenced if QUTOL < 0. +C +C LDCD INTEGER +C The leading dimension of the array CD. +C LDCD >= MAX(1,MP+F), if QUTOL >= 0; +C LDCD >= 1, if QUTOL < 0. +C +C DD (output) DOUBLE PRECISION array, dimension (LDDD,MP+F) +C The leading (MP+F)-by-(MP+F) part of this array contains +C the D matrix of the D-scaling system. +C Not referenced if QUTOL < 0. +C +C LDDD INTEGER +C The leading dimension of the array DD. +C LDDD >= MAX(1,MP+F), if QUTOL >= 0; +C LDDD >= 1, if QUTOL < 0. +C +C MJU (output) DOUBLE PRECISION array, dimension (LENDAT) +C The vector with the upper bound of the structured +C singular value (mju) for each frequency in OMEGA. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C +C LIWORK INTEGER +C The length of the array IWORK. +C LIWORK >= MAX( NC, 4*MNB-2, MP, 2*ORD+1 ), if QUTOL >= 0; +C LIWORK >= MAX( NC, 4*MNB-2, MP ), if QUTOL < 0. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK, DWORK(2) returns the optimal value of LZWORK, +C and DWORK(3) returns an estimate of the minimum reciprocal +C of the condition numbers (with respect to inversion) of +C the generated Hessenberg matrices. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 3, LWM, LWD ), where +C LWM = LWA + MAX( NC + MAX( NC, MP-1 ), +C 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + +C MP*MNB + 11*MP + 33*MNB - 11 ); +C LWD = LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ), +C if QUTOL >= 0; +C LWD = 0, if QUTOL < 0; +C LWA = MP*LENDAT + 2*MNB + MP - 1; +C LWB = LENDAT*(MP + 2) + ORD*(ORD + 2) + 1; +C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; +C LW2 = LENDAT + 6*HNPTS; MN = MIN( 2*LENDAT, 2*ORD+1 ); +C LW3 = 2*LENDAT*(2*ORD + 1) + MAX( 2*LENDAT, 2*ORD + 1 ) + +C MAX( MN + 6*ORD + 4, 2*MN + 1 ); +C LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ). +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX( LZM, LZD ), where +C LZM = MAX( MP*MP + NC*MP + NC*NC + 2*NC, +C 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ); +C LZD = MAX( LENDAT*(2*ORD + 3), ORD*ORD + 3*ORD + 1 ), +C if QUTOL >= 0; +C LZD = 0, if QUTOL < 0. +C +C Error indicator +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if one or more values w in OMEGA are (close to +C some) poles of the closed-loop system, i.e., the +C matrix jw*I - A is (numerically) singular; +C = 2: the block sizes must be positive integers; +C = 3: the sum of block sizes must be equal to MP; +C = 4: the size of a real block must be equal to 1; +C = 5: the block type must be either 1 or 2; +C = 6: errors in solving linear equations or in matrix +C inversion; +C = 7: errors in computing eigenvalues or singular values. +C = 1i: INFO on exit from SB10YD is i. (1i means 10 + i.) +C +C METHOD +C +C I. First, W(jw) for the given closed-loop system is being +C estimated. +C II. Now, AB13MD SLICOT subroutine can obtain the D(jw) scaling +C system with respect to NBLOCK and ITYPE, and colaterally, +C mju(jw). +C If QUTOL < 0 then the estimations stop and the routine exits. +C III. Now that we have D(jw), SB10YD subroutine can do block-by- +C block fit. For each block it tries with an increasing order +C of the fit, starting with 1 until the +C (mean quadratic error + max quadratic error)/2 +C between the Dii(jw) and the estimated frequency responce +C of the block becomes less than or equal to the routine +C argument QUTOL, or the order becomes equal to ORD. +C IV. Arrange the obtained blocks in the AD, BD, CD and DD +C matrices and estimate the total order of D(s), TOTORD. +C V. Add the system I_f to the system obtained in IV. +C +C REFERENCES +C +C [1] Balas, G., Doyle, J., Glover, K., Packard, A. and Smith, R. +C Mu-analysis and Synthesis toolbox - User's Guide, +C The Mathworks Inc., Natick, MA, USA, 1998. +C +C CONTRIBUTORS +C +C Asparuh Markovski, Technical University of Sofia, July 2003. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. +C A. Markovski, V. Sima, October 2003. +C +C KEYWORDS +C +C Frequency response, H-infinity optimal control, robust control, +C structured singular value. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ THREE = 3.0D+0 ) + INTEGER HNPTS + PARAMETER ( HNPTS = 2048 ) +C .. +C .. Scalar Arguments .. + INTEGER F, INFO, LDA, LDAD, LDB, LDBD, LDC, LDCD, LDD, + $ LDDD, LDWORK, LENDAT, LIWORK, LZWORK, MNB, MP, + $ NC, ORD, TOTORD + DOUBLE PRECISION QUTOL +C .. +C .. Array Arguments .. + INTEGER ITYPE(*), IWORK(*), NBLOCK(*) + DOUBLE PRECISION A(LDA, *), AD(LDAD, *), B(LDB, *), BD(LDBD, *), + $ C(LDC, *), CD(LDCD, *), D(LDD, *), DD(LDDD, *), + $ DWORK(*), MJU(*), OMEGA(*) + COMPLEX*16 ZWORK(*) +C .. +C .. Local Scalars .. + CHARACTER BALEIG, INITA + INTEGER CLWMAX, CORD, DLWMAX, I, IC, ICWRK, IDWRK, II, + $ INFO2, IWAD, IWB, IWBD, IWCD, IWDD, IWGJOM, + $ IWIFRD, IWRFRD, IWX, K, LCSIZE, LDSIZE, LORD, + $ LW1, LW2, LW3, LW4, LWA, LWB, MAXCWR, MAXWRK, + $ MN, W + DOUBLE PRECISION MAQE, MEQE, MOD1, MOD2, RCND, RCOND, RQE, TOL, + $ TOLER + COMPLEX*16 FREQ +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL AB13MD, DCOPY, DLACPY, DLASET, DSCAL, SB10YD, + $ TB05AD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, INT, MAX, MIN, SQRT +C +C Decode and test input parameters. +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C Workspace usage 1. +C +C real +C + IWX = 1 + MP*LENDAT + IWGJOM = IWX + 2*MNB - 1 + IDWRK = IWGJOM + MP + LDSIZE = LDWORK - IDWRK + 1 +C +C complex +C + IWB = MP*MP + 1 + ICWRK = IWB + NC*MP + LCSIZE = LZWORK - ICWRK + 1 +C + INFO = 0 + IF ( NC.LT.0 ) THEN + INFO = -1 + ELSE IF( MP.LT.0 ) THEN + INFO = -2 + ELSE IF( LENDAT.LT.2 ) THEN + INFO = -3 + ELSE IF( F.LT.0 ) THEN + INFO = -4 + ELSE IF( ORD.GT.LENDAT - 1 ) THEN + INFO = -5 + ELSE IF( MNB.LT.1 .OR. MNB.GT.MP ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, NC ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, NC ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, MP ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.MAX( 1, MP ) ) THEN + INFO = -17 + ELSE IF( LDAD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDAD.LT.MP*ORD ) ) + $ THEN + INFO = -21 + ELSE IF( LDBD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDBD.LT.MP*ORD ) ) + $ THEN + INFO = -23 + ELSE IF( LDCD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDCD.LT.MP + F ) ) + $ THEN + INFO = -25 + ELSE IF( LDDD.LT.1 .OR. ( QUTOL.GE.ZERO .AND. LDDD.LT.MP + F ) ) + $ THEN + INFO = -27 + ELSE +C +C Compute workspace. +C + II = MAX( NC, 4*MNB - 2, MP ) + MN = MIN( 2*LENDAT, 2*ORD + 1 ) + LWA = IDWRK - 1 + LWB = LENDAT*( MP + 2 ) + ORD*( ORD + 2 ) + 1 + LW1 = 2*LENDAT + 4*HNPTS + LW2 = LENDAT + 6*HNPTS + LW3 = 2*LENDAT*( 2*ORD + 1 ) + MAX( 2*LENDAT, 2*ORD + 1 ) + + $ MAX( MN + 6*ORD + 4, 2*MN + 1 ) + LW4 = MAX( ORD*ORD + 5*ORD, 6*ORD + 1 + MIN( 1, ORD ) ) +C + DLWMAX = LWA + MAX( NC + MAX( NC, MP - 1 ), + $ 2*MP*MP*MNB - MP*MP + 9*MNB*MNB + MP*MNB + + $ 11*MP + 33*MNB - 11 ) +C + CLWMAX = MAX( ICWRK - 1 + NC*NC + 2*NC, + $ 6*MP*MP*MNB + 13*MP*MP + 6*MNB + 6*MP - 3 ) +C + IF ( QUTOL.GE.ZERO ) THEN + II = MAX( II, 2*ORD + 1 ) + DLWMAX = MAX( DLWMAX, + $ LWB + MAX( 2, LW1, LW2, LW3, LW4, 2*ORD ) ) + CLWMAX = MAX( CLWMAX, LENDAT*( 2*ORD + 3 ), + $ ORD*( ORD + 3 ) + 1 ) + END IF + IF ( LIWORK.LT.II ) THEN + INFO = -30 + ELSE IF ( LDWORK.LT.MAX( 3, DLWMAX ) ) THEN + INFO = -32 + ELSE IF ( LZWORK.LT.CLWMAX ) THEN + INFO = -34 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB10MD', -INFO ) + RETURN + END IF +C + ORD = MAX( 1, ORD ) + TOTORD = 0 +C +C Quick return if possible. +C + IF( NC.EQ.0 .OR. MP.EQ.0 ) THEN + DWORK(1) = THREE + DWORK(2) = ZERO + DWORK(3) = ONE + RETURN + END IF +C + TOLER = SQRT( DLAMCH( 'Epsilon' ) ) +C + BALEIG = 'C' + RCOND = ONE + MAXCWR = CLWMAX +C +C @@@ 1. Estimate W(jw) for the closed-loop system, @@@ +C @@@ D(jw) and mju(jw) for each frequency. @@@ +C + DO 30 W = 1, LENDAT + FREQ = DCMPLX( ZERO, OMEGA(W) ) + IF ( W.EQ.1 ) THEN + INITA = 'G' + ELSE + INITA = 'H' + END IF +C +C Compute C*inv(jw*I-A)*B. +C Integer workspace: need NC. +C Real workspace: need LWA + NC + MAX(NC,MP-1); +C prefer larger, +C where LWA = MP*LENDAT + 2*MNB + MP - 1. +C Complex workspace: need MP*MP + NC*MP + NC*NC + 2*NC. +C + CALL TB05AD( BALEIG, INITA, NC, MP, MP, FREQ, A, LDA, B, LDB, + $ C, LDC, RCND, ZWORK, MP, DWORK, DWORK, ZWORK(IWB), + $ NC, IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), + $ LCSIZE, INFO2 ) +C + IF ( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + RCOND = MIN( RCOND, RCND ) + IF ( W.EQ.1 ) + $ MAXWRK = INT( DWORK(IDWRK) + IDWRK - 1 ) + IC = 0 +C +C D + C*inv(jw*I-A)*B +C + DO 20 K = 1, MP + DO 10 I = 1, MP + IC = IC + 1 + ZWORK(IC) = ZWORK(IC) + DCMPLX ( D(I,K), ZERO ) + 10 CONTINUE + 20 CONTINUE +C +C Estimate D(jw) and mju(jw). +C Integer workspace: need MAX(4*MNB-2,MP). +C Real workspace: need LWA + 2*MP*MP*MNB - MP*MP + 9*MNB*MNB +C + MP*MNB + 11*MP + 33*MNB - 11; +C prefer larger. +C Complex workspace: need 6*MP*MP*MNB + 13*MP*MP + 6*MNB + +C 6*MP - 3. +C + CALL AB13MD( 'N', MP, ZWORK, MP, MNB, NBLOCK, ITYPE, + $ DWORK(IWX), MJU(W), DWORK((W-1)*MP+1), + $ DWORK(IWGJOM), IWORK, DWORK(IDWRK), LDSIZE, + $ ZWORK(IWB), LZWORK-IWB+1, INFO2 ) +C + IF ( INFO2.NE.0 ) THEN + INFO = INFO2 + 1 + RETURN + END IF +C + IF ( W.EQ.1 ) THEN + MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1 ) + MAXCWR = MAX( MAXCWR, INT( ZWORK(IWB) ) + IWB - 1 ) + END IF +C +C Normalize D(jw) through it's last entry. +C + IF ( DWORK(W*MP).NE.ZERO ) + $ CALL DSCAL( MP, ONE/DWORK(W*MP), DWORK((W-1)*MP+1), 1 ) +C + 30 CONTINUE +C +C Quick return if needed. +C + IF ( QUTOL.LT.ZERO ) THEN + DWORK(1) = MAXWRK + DWORK(2) = MAXCWR + DWORK(3) = RCOND + RETURN + END IF +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C Workspace usage 2. +C +C real +C + IWRFRD = IWX + IWIFRD = IWRFRD + LENDAT + IWAD = IWIFRD + LENDAT + IWBD = IWAD + ORD*ORD + IWCD = IWBD + ORD + IWDD = IWCD + ORD + IDWRK = IWDD + 1 + LDSIZE = LDWORK - IDWRK + 1 +C +C complex +C + ICWRK = ORD + 2 + LCSIZE = LZWORK - ICWRK + 1 + INITA = 'H' +C +C Use default tolerance for SB10YD. +C + TOL = -ONE +C +C @@@ 2. Clear imag parts of D(jw) for SB10YD. @@@ +C + DO 40 I = 1, LENDAT + DWORK(IWIFRD+I-1) = ZERO + 40 CONTINUE +C +C @@@ 3. Clear AD, BD, CD and initialize DD with I_(mp+f). @@@ +C + CALL DLASET( 'Full', MP*ORD, MP*ORD, ZERO, ZERO, AD, LDAD ) + CALL DLASET( 'Full', MP*ORD, MP+F, ZERO, ZERO, BD, LDBD ) + CALL DLASET( 'Full', MP+F, MP*ORD, ZERO, ZERO, CD, LDCD ) + CALL DLASET( 'Full', MP+F, MP+F, ZERO, ONE, DD, LDDD ) +C +C @@@ 4. Block by block frequency identification. @@@ +C + DO 80 II = 1, MP +C + CALL DCOPY( LENDAT, DWORK(II), MP, DWORK(IWRFRD), 1 ) +C +C Increase CORD from 1 to ORD for every block, if needed. +C + CORD = 1 +C + 50 CONTINUE + LORD = CORD +C +C Now, LORD is the desired order. +C Integer workspace: need 2*N+1, where N = LORD. +C Real workspace: need LWB + MAX( 2, LW1, LW2, LW3, LW4), +C where +C LWB = LENDAT*(MP+2) + +C ORD*(ORD+2) + 1, +C HNPTS = 2048, and +C LW1 = 2*LENDAT + 4*HNPTS; +C LW2 = LENDAT + 6*HNPTS; +C MN = min( 2*LENDAT, 2*N+1 ) +C LW3 = 2*LENDAT*(2*N+1) + +C max( 2*LENDAT, 2*N+1 ) + +C max( MN + 6*N + 4, 2*MN+1 ); +C LW4 = max( N*N + 5*N, +C 6*N + 1 + min( 1,N ) ); +C prefer larger. +C Complex workspace: need LENDAT*(2*N+3). +C + CALL SB10YD( 0, 1, LENDAT, DWORK(IWRFRD), DWORK(IWIFRD), + $ OMEGA, LORD, DWORK(IWAD), ORD, DWORK(IWBD), + $ DWORK(IWCD), DWORK(IWDD), TOL, IWORK, + $ DWORK(IDWRK), LDSIZE, ZWORK, LZWORK, INFO2 ) +C +C At this point, LORD is the actual order reached by SB10YD, +C 0 <= LORD <= CORD. +C [ADi,BDi; CDi,DDi] is a minimal realization with ADi in +C upper Hessenberg form. +C The leading LORD-by-LORD part of ORD-by-ORD DWORK(IWAD) +C contains ADi, the leading LORD-by-1 part of ORD-by-1 +C DWORK(IWBD) contains BDi, the leading 1-by-LORD part of +C 1-by-ORD DWORK(IWCD) contains CDi, DWORK(IWDD) contains DDi. +C + IF ( INFO2.NE.0 ) THEN + INFO = 10 + INFO2 + RETURN + END IF +C +C Compare the original D(jw) with the fitted one. +C + MEQE = ZERO + MAQE = ZERO +C + DO 60 W = 1, LENDAT + FREQ = DCMPLX( ZERO, OMEGA(W) ) +C +C Compute CD*inv(jw*I-AD)*BD. +C Integer workspace: need LORD. +C Real workspace: need LWB + 2*LORD; +C prefer larger. +C Complex workspace: need 1 + ORD + LORD*LORD + 2*LORD. +C + CALL TB05AD( BALEIG, INITA, LORD, 1, 1, FREQ, + $ DWORK(IWAD), ORD, DWORK(IWBD), ORD, + $ DWORK(IWCD), 1, RCND, ZWORK, 1, + $ DWORK(IDWRK), DWORK(IDWRK), ZWORK(2), ORD, + $ IWORK, DWORK(IDWRK), LDSIZE, ZWORK(ICWRK), + $ LCSIZE, INFO2 ) +C + IF ( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + RCOND = MIN( RCOND, RCND ) + IF ( W.EQ.1 ) + $ MAXWRK = MAX( MAXWRK, INT( DWORK(IDWRK) ) + IDWRK - 1) +C +C DD + CD*inv(jw*I-AD)*BD +C + ZWORK(1) = ZWORK(1) + DCMPLX( DWORK(IWDD), ZERO ) +C + MOD1 = ABS( DWORK(IWRFRD+W-1) ) + MOD2 = ABS( ZWORK(1) ) + RQE = ABS( ( MOD1 - MOD2 )/( MOD1 + TOLER ) ) + MEQE = MEQE + RQE + MAQE = MAX( MAQE, RQE ) +C + 60 CONTINUE +C + MEQE = MEQE/LENDAT +C + IF ( ( ( MEQE + MAQE )/TWO.LE.QUTOL ) .OR. + $ ( CORD.EQ.ORD ) ) THEN + GOTO 70 + END IF +C + CORD = CORD + 1 + GOTO 50 +C + 70 TOTORD = TOTORD + LORD +C +C Copy ad(ii), bd(ii) and cd(ii) to AD, BD and CD, respectively. +C + CALL DLACPY( 'Full', LORD, LORD, DWORK(IWAD), ORD, + $ AD(TOTORD-LORD+1,TOTORD-LORD+1), LDAD ) + CALL DCOPY( LORD, DWORK(IWBD), 1, BD(TOTORD-LORD+1,II), 1 ) + CALL DCOPY( LORD, DWORK(IWCD), 1, CD(II,TOTORD-LORD+1), LDCD ) +C +C Copy dd(ii) to DD. +C + DD(II,II) = DWORK(IWDD) +C + 80 CONTINUE +C + DWORK(1) = MAXWRK + DWORK(2) = MAXCWR + DWORK(3) = RCOND + RETURN +C +C *** Last line of SB10MD *** + END diff --git a/mex/sources/libslicot/SB10PD.f b/mex/sources/libslicot/SB10PD.f new file mode 100644 index 000000000..617bdd29b --- /dev/null +++ b/mex/sources/libslicot/SB10PD.f @@ -0,0 +1,505 @@ + SUBROUTINE SB10PD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the matrices D12 and D21 of the linear time-invariant +C system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C to unit diagonal form, to transform the matrices B, C, and D11 to +C satisfy the formulas in the computation of an H2 and H-infinity +C (sub)optimal controllers and to check the rank conditions. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading NP-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading NP-by-N part of this array contains +C the transformed system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading NP-by-M part of this array must +C contain the system input/output matrix D. The +C NMEAS-by-NCON trailing submatrix D22 is not referenced. +C On exit, the leading (NP-NMEAS)-by-(M-NCON) part of this +C array contains the transformed submatrix D11. +C The transformed submatrices D12 = [ 0 Im2 ]' and +C D21 = [ 0 Inp2 ] are not stored. The corresponding part +C of this array contains no useful information. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array contains the +C control transformation matrix TU. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array contains the +C measurement transformation matrix TY. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C RCOND (output) DOUBLE PRECISION array, dimension (2) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix TU; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix TY. +C RCOND is set even if INFO = 3 or INFO = 4; if INFO = 3, +C then RCOND(2) was not computed, but it is set to 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations. Transformation matrices TU and TY whose +C reciprocal condition numbers are less than TOL are not +C allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1,LW1,LW2,LW3,LW4), where +C LW1 = (N+NP1+1)*(N+M2) + MAX(3*(N+M2)+N+NP1,5*(N+M2)), +C LW2 = (N+NP2)*(N+M1+1) + MAX(3*(N+NP2)+N+M1,5*(N+NP2)), +C LW3 = M2 + NP1*NP1 + MAX(NP1*MAX(N,M1),3*M2+NP1,5*M2), +C LW4 = NP2 + M1*M1 + MAX(MAX(N,NP1)*M1,3*NP2+M1,5*NP2), +C with M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C MAX(1,(N+Q)*(N+Q+6),Q*(Q+MAX(N,Q,5)+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix | A B2 | had not full column rank +C | C1 D12 | +C in respect to the tolerance EPS; +C = 2: if the matrix | A B1 | had not full row rank in +C | C2 D21 | +C respect to the tolerance EPS; +C = 3: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 4: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 5: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of one of +C the matrices |A B2 |, |A B1 |, D12 or D21). +C |C1 D12| |C2 D21| +C +C METHOD +C +C The routine performs the transformations described in [2]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The precision of the transformations can be controlled by the +C condition numbers of the matrices TU and TY as given by the +C values of RCOND(1) and RCOND(2), respectively. An error return +C with INFO = 3 or INFO = 4 will be obtained if the condition +C number of TU or TY, respectively, would exceed 1/TOL. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Feb. 2000. +C +C KEYWORDS +C +C H-infinity optimal control, robust control, singular value +C decomposition. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDTU, LDTY, LDWORK, + $ M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), RCOND( 2 ), + $ TU( LDTU, * ), TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER IEXT, INFO2, IQ, IWRK, J, LWAMAX, M1, M2, + $ MINWRK, ND1, ND2, NP1, NP2 + DOUBLE PRECISION EPS, TOLL +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -15 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -17 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, + $ ( N + NP1 + 1 )*( N + M2 ) + + $ MAX( 3*( N + M2 ) + N + NP1, 5*( N + M2 ) ), + $ ( N + NP2 )*( N + M1 + 1 ) + + $ MAX( 3*( N + NP2 ) + N + M1, 5*( N + NP2 ) ), + $ M2 + NP1*NP1 + MAX( NP1*MAX( N, M1 ), 3*M2 + NP1, + $ 5*M2 ), + $ NP2 + M1*M1 + MAX( MAX( N, NP1 )*M1, 3*NP2 + M1, + $ 5*NP2 ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -21 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + EPS = DLAMCH( 'Epsilon' ) + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for condition tests. +C + TOLL = SQRT( EPS ) + END IF +C +C Determine if |A-jwI B2 | has full column rank at w = 0. +C | C1 D12| +C Workspace: need (N+NP1+1)*(N+M2) + +C max(3*(N+M2)+N+NP1,5*(N+M2)); +C prefer larger. +C + IEXT = N + M2 + 1 + IWRK = IEXT + ( N + NP1 )*( N + M2 ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP1 ) + CALL DLACPY( 'Full', NP1, N, C, LDC, DWORK( IEXT+N ), N+NP1 ) + CALL DLACPY( 'Full', N, M2, B( 1, M1+1 ), LDB, + $ DWORK( IEXT+(N+NP1)*N ), N+NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( IEXT+(N+NP1)*N+N ), N+NP1 ) + CALL DGESVD( 'N', 'N', N+NP1, N+M2, DWORK( IEXT ), N+NP1, DWORK, + $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + IF( DWORK( N+M2 )/DWORK( 1 ).LE.EPS ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Determine if |A-jwI B1 | has full row rank at w = 0. +C | C2 D21| +C Workspace: need (N+NP2)*(N+M1+1) + +C max(3*(N+NP2)+N+M1,5*(N+NP2)); +C prefer larger. +C + IEXT = N + NP2 + 1 + IWRK = IEXT + ( N + NP2 )*( N + M1 ) + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IEXT ), N+NP2 ) + CALL DLACPY( 'Full', NP2, N, C( NP1+1, 1), LDC, DWORK( IEXT+N ), + $ N+NP2 ) + CALL DLACPY( 'Full', N, M1, B, LDB, DWORK( IEXT+(N+NP2)*N ), + $ N+NP2 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( IEXT+(N+NP2)*N+N ), N+NP2 ) + CALL DGESVD( 'N', 'N', N+NP2, N+M1, DWORK( IEXT ), N+NP2, DWORK, + $ TU, LDTU, TY, LDTY, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + IF( DWORK( N+NP2 )/DWORK( 1 ).LE.EPS ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has +C full column rank. V12' is stored in TU. +C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); +C prefer larger. +C + IQ = M2 + 1 + IWRK = IQ + NP1*NP1 +C + CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, + $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF +C + RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) + IF( RCOND( 1 ).LE.TOLL ) THEN + RCOND( 2 ) = ZERO + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine Q12. +C + IF( ND1.GT.0 ) THEN + CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), + $ LDD ) + CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, + $ DWORK( IQ ), NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( IQ+NP1*ND1 ), NP1 ) + END IF +C +C Determine Tu by transposing in-situ and scaling. +C + DO 10 J = 1, M2 - 1 + CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) + 10 CONTINUE +C + DO 20 J = 1, M2 + CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) + 20 CONTINUE +C +C Determine C1 =: Q12'*C1. +C Workspace: M2 + NP1*NP1 + NP1*N. +C + CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) + LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) +C +C Determine D11 =: Q12'*D11. +C Workspace: M2 + NP1*NP1 + NP1*M1. +C + CALL DGEMM( 'T', 'N', NP1, M1, NP1, ONE, DWORK( IQ ), NP1, D, LDD, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) + LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) +C +C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has +C full row rank. U21 is stored in TY. +C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); +C prefer larger. +C + IQ = NP2 + 1 + IWRK = IQ + M1*M1 +C + CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, + $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF +C + RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) + IF( RCOND( 2 ).LE.TOLL ) THEN + INFO = 4 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine Q21. +C + IF( ND2.GT.0 ) THEN + CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), + $ LDD ) + CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), + $ M1 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( IQ+ND2 ), M1 ) + END IF +C +C Determine Ty by scaling and transposing in-situ. +C + DO 30 J = 1, NP2 + CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) + 30 CONTINUE +C + DO 40 J = 1, NP2 - 1 + CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) + 40 CONTINUE +C +C Determine B1 =: B1*Q21'. +C Workspace: NP2 + M1*M1 + N*M1. +C + CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, + $ ZERO, DWORK( IWRK ), N ) + CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) + LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) +C +C Determine D11 =: D11*Q21'. +C Workspace: NP2 + M1*M1 + NP1*M1. +C + CALL DGEMM( 'N', 'T', NP1, M1, M1, ONE, D, LDD, DWORK( IQ ), M1, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, M1, DWORK( IWRK ), NP1, D, LDD ) + LWAMAX = MAX( IWRK + NP1*M1 - 1, LWAMAX ) +C +C Determine B2 =: B2*Tu. +C Workspace: N*M2. +C + CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, + $ ZERO, DWORK, N ) + CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) +C +C Determine C2 =: Ty*C2. +C Workspace: NP2*N. +C + CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, + $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) + CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) +C + LWAMAX = MAX( N*MAX( M2, NP2 ), LWAMAX ) + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10PD *** + END diff --git a/mex/sources/libslicot/SB10QD.f b/mex/sources/libslicot/SB10QD.f new file mode 100644 index 000000000..6b64f8396 --- /dev/null +++ b/mex/sources/libslicot/SB10QD.f @@ -0,0 +1,602 @@ + SUBROUTINE SB10QD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, F, LDF, H, LDH, X, LDX, Y, LDY, + $ XYCOND, IWORK, DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the state feedback and the output injection +C matrices for an H-infinity (sub)optimal n-state controller, +C using Glover's and Doyle's 1988 formulas, for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 D22 | +C +C and for a given value of gamma, where B2 has as column size the +C number of control inputs (NCON) and C2 has as row size the number +C of measurements (NMEAS) being provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank with D12 = | 0 | and D21 is +C | I | +C full row rank with D21 = | 0 I | as obtained by the +C subroutine SB10PD, +C +C (A3) | A-j*omega*I B2 | has full column rank for all omega, +C | C1 D12 | +C +C +C (A4) | A-j*omega*I B1 | has full row rank for all omega. +C | C2 D21 | +C +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array contains the state +C feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,M). +C +C H (output) DOUBLE PRECISION array, dimension (LDH,NP) +C The leading N-by-NP part of this array contains the output +C injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the matrix +C Y, solution of the Y-Riccati equation. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C XYCOND (output) DOUBLE PRECISION array, dimension (2) +C XYCOND(1) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C XYCOND(2) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*max(N,M-NCON,NP-NMEAS),N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(1,M*M + max(2*M1,3*N*N + +C max(N*M,10*N*N+12*N+5)), +C NP*NP + max(2*NP1,3*N*N + +C max(N*NP,10*N*N+12*N+5))), +C where M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C max(1,4*Q*Q+max(2*Q,3*N*N + max(2*N*Q,10*N*N+12*N+5))). +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the controller is not admissible (too small value +C of gamma); +C = 2: if the X-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties); +C = 3: if the Y-Riccati equation was not solved +C successfully (the controller is not admissible or +C there are numerical difficulties). +C +C METHOD +C +C The routine implements the Glover's and Doyle's formulas [1],[2] +C modified as described in [3]. The X- and Y-Riccati equations +C are solved with condition and accuracy estimates [4]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of continuous-time +C linear control systems. +C Rep. 98-14, Department of Engineering, Leicester University, +C Leicester, U.K., 1998. +C +C [4] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. +C DGRSVX and DMSRIC: Fortan 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. +C Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C +C The precision of the solution of the matrix Riccati equations +C can be controlled by the values of the condition numbers +C XYCOND(1) and XYCOND(2) of these equations. +C +C FURTHER COMMENTS +C +C The Riccati equations are solved by the Schur approach +C implementing condition and accuracy estimates. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDF, LDH, LDWORK, + $ LDX, LDY, M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), DWORK( * ), F( LDF, * ), + $ H( LDH, * ), X( LDX, * ), XYCOND( 2 ), + $ Y( LDY, * ) + LOGICAL BWORK( * ) +C +C .. +C .. Local Scalars .. + INTEGER INFO2, IW2, IWA, IWG, IWI, IWQ, IWR, IWRK, IWS, + $ IWT, IWV, LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, + $ NN, NP1, NP2 + DOUBLE PRECISION ANORM, EPS, FERR, RCOND, SEP +C .. +C .. External Functions .. +C + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DSYCON, DSYMM, DSYRK, + $ DSYTRF, DSYTRI, MB01RU, MB01RX, SB02RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS + NN = N*N +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -20 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, M*M + MAX( 2*M1, 3*NN + + $ MAX( N*M, 10*NN + 12*N + 5 ) ), + $ NP*NP + MAX( 2*NP1, 3*NN + + $ MAX( N*NP, 10*NN + 12*N + 5 ) ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -26 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + XYCOND( 1 ) = ONE + XYCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF + ND1 = NP1 - M2 + ND2 = M1 - NP2 + N2 = 2*N +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Workspace usage. +C + IWA = M*M + 1 + IWQ = IWA + NN + IWG = IWQ + NN + IW2 = IWG + NN +C +C Compute |D1111'||D1111 D1112| - gamma^2*Im1 . +C |D1112'| +C + CALL DLASET( 'L', M1, M1, ZERO, -GAMMA*GAMMA, DWORK, M ) + IF( ND1.GT.0 ) + $ CALL DSYRK( 'L', 'T', M1, ND1, ONE, D, LDD, ONE, DWORK, M ) +C +C Compute inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . +C |D1112'| +C + IWRK = IWA + ANORM = DLANSY( 'I', 'L', M1, DWORK, M, DWORK( IWRK ) ) + CALL DSYTRF( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 + CALL DSYCON( 'L', M1, DWORK, M, IWORK, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( M1+1 ), INFO2 ) + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(R) block by block. +C + CALL DSYTRI( 'L', M1, DWORK, M, IWORK, DWORK( IWRK ), INFO2 ) +C +C Compute -|D1121 D1122|*inv(|D1111'|*|D1111 D1112| - gamma^2*Im1) . +C |D1112'| +C + CALL DSYMM( 'R', 'L', M2, M1, -ONE, DWORK, M, D( ND1+1, 1 ), LDD, + $ ZERO, DWORK( M1+1 ), M ) +C +C Compute |D1121 D1122|*inv(|D1111'|*|D1111 D1112| - +C |D1112'| +C +C gamma^2*Im1)*|D1121'| + Im2 . +C |D1122'| +C + CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( M1*(M+1)+1 ), M ) + CALL MB01RX( 'Right', 'Lower', 'Transpose', M2, M1, ONE, -ONE, + $ DWORK( M1*(M+1)+1 ), M, D( ND1+1, 1 ), LDD, + $ DWORK( M1+1 ), M, INFO2 ) +C +C Compute D11'*C1 . +C + CALL DGEMM( 'T', 'N', M1, N, NP1, ONE, D, LDD, C, LDC, ZERO, + $ DWORK( IW2 ), M ) +C +C Compute D1D'*C1 . +C + CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, DWORK( IW2+M1 ), + $ M ) +C +C Compute inv(R)*D1D'*C1 in F . +C + CALL DSYMM( 'L', 'L', M, N, ONE, DWORK, M, DWORK( IW2 ), M, ZERO, + $ F, LDF ) +C +C Compute Ax = A - B*inv(R)*D1D'*C1 . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) + CALL DGEMM( 'N', 'N', N, N, M, -ONE, B, LDB, F, LDF, ONE, + $ DWORK( IWA ), N ) +C +C Compute Cx = C1'*C1 - C1'*D1D*inv(R)*D1D'*C1 . +C + IF( ND1.EQ.0 ) THEN + CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + ELSE + CALL DSYRK( 'L', 'T', N, NP1, ONE, C, LDC, ZERO, + $ DWORK( IWQ ), N ) + CALL MB01RX( 'Left', 'Lower', 'Transpose', N, M, ONE, -ONE, + $ DWORK( IWQ ), N, DWORK( IW2 ), M, F, LDF, INFO2 ) + END IF +C +C Compute Dx = B*inv(R)*B' . +C + IWRK = IW2 + CALL MB01RU( 'Lower', 'NoTranspose', N, M, ZERO, ONE, + $ DWORK( IWG ), N, B, LDB, DWORK, M, DWORK( IWRK ), + $ M*N, INFO2 ) +C +C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . +C Workspace: need M*M + 13*N*N + 12*N + 5; +C prefer larger. +C + IWT = IW2 + IWV = IWT + NN + IWR = IWV + NN + IWI = IWR + N2 + IWS = IWI + N2 + IWRK = IWS + 4*NN +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', + $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute F = -inv(R)*|D1D'*C1 + B'*X| . +C + IWRK = IW2 + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, X, LDX, ZERO, + $ DWORK( IWRK ), M ) + CALL DSYMM( 'L', 'L', M, N, -ONE, DWORK, M, DWORK( IWRK ), M, + $ -ONE, F, LDF ) +C +C Workspace usage. +C + IWA = NP*NP + 1 + IWQ = IWA + NN + IWG = IWQ + NN + IW2 = IWG + NN +C +C Compute |D1111|*|D1111' D1121'| - gamma^2*Inp1 . +C |D1121| +C + CALL DLASET( 'U', NP1, NP1, ZERO, -GAMMA*GAMMA, DWORK, NP ) + IF( ND2.GT.0 ) + $ CALL DSYRK( 'U', 'N', NP1, ND2, ONE, D, LDD, ONE, DWORK, NP ) +C +C Compute inv(|D1111|*|D1111' D1121'| - gamma^2*Inp1) . +C |D1121| +C + IWRK = IWA + ANORM = DLANSY( 'I', 'U', NP1, DWORK, NP, DWORK( IWRK ) ) + CALL DSYTRF( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) + CALL DSYCON( 'U', NP1, DWORK, NP, IWORK, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( NP1+1 ), INFO2 ) + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(RT) . +C + CALL DSYTRI( 'U', NP1, DWORK, NP, IWORK, DWORK( IWRK ), INFO2 ) +C +C Compute -inv(|D1111||D1111' D1121'| - gamma^2*Inp1)*|D1112| . +C |D1121| |D1122| +C + CALL DSYMM( 'L', 'U', NP1, NP2, -ONE, DWORK, NP, D( 1, ND2+1 ), + $ LDD, ZERO, DWORK( NP1*NP+1 ), NP ) +C +C Compute [D1112' D1122']*inv(|D1111||D1111' D1121'| - +C |D1121| +C +C gamma^2*Inp1)*|D1112| + Inp2 . +C |D1122| +C + CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( NP1*(NP+1)+1 ), + $ NP ) + CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, NP1, ONE, -ONE, + $ DWORK( NP1*(NP+1)+1 ), NP, D( 1, ND2+1 ), LDD, + $ DWORK( NP1*NP+1 ), NP, INFO2 ) +C +C Compute B1*D11' . +C + CALL DGEMM( 'N', 'T', N, NP1, M1, ONE, B, LDB, D, LDD, ZERO, + $ DWORK( IW2 ), N ) +C +C Compute B1*DD1' . +C + CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, + $ DWORK( IW2+NP1*N ), N ) +C +C Compute B1*DD1'*inv(RT) in H . +C + CALL DSYMM( 'R', 'U', N, NP, ONE, DWORK, NP, DWORK( IW2 ), N, + $ ZERO, H, LDH ) +C +C Compute Ay = A - B1*DD1'*inv(RT)*C . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK( IWA ), N ) + CALL DGEMM( 'N', 'N', N, N, NP, -ONE, H, LDH, C, LDC, ONE, + $ DWORK( IWA ), N ) +C +C Compute Cy = B1*B1' - B1*DD1'*inv(RT)*DD1*B1' . +C + IF( ND2.EQ.0 ) THEN + CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + ELSE + CALL DSYRK( 'U', 'N', N, M1, ONE, B, LDB, ZERO, DWORK( IWQ ), + $ N ) + CALL MB01RX( 'Right', 'Upper', 'Transpose', N, NP, ONE, -ONE, + $ DWORK( IWQ ), N, H, LDH, DWORK( IW2 ), N, INFO2 ) + END IF +C +C Compute Dy = C'*inv(RT)*C . +C + IWRK = IW2 + CALL MB01RU( 'Upper', 'Transpose', N, NP, ZERO, ONE, DWORK( IWG ), + $ N, C, LDC, DWORK, NP, DWORK( IWRK), N*NP, INFO2 ) +C +C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . +C Workspace: need NP*NP + 13*N*N + 12*N + 5; +C prefer larger. +C + IWT = IW2 + IWV = IWT + NN + IWR = IWV + NN + IWI = IWR + N2 + IWS = IWI + N2 + IWRK = IWS + 4*NN +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', + $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK( IWA ), N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute H = -|B1*DD1' + Y*C'|*inv(RT) . +C + IWRK = IW2 + CALL DGEMM( 'N', 'T', N, NP, N, ONE, Y, LDY, C, LDC, ZERO, + $ DWORK( IWRK ), N ) + CALL DSYMM( 'R', 'U', N, NP, -ONE, DWORK, NP, DWORK( IWRK ), N, + $ -ONE, H, LDH ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10QD *** + END diff --git a/mex/sources/libslicot/SB10RD.f b/mex/sources/libslicot/SB10RD.f new file mode 100644 index 000000000..86d483bb3 --- /dev/null +++ b/mex/sources/libslicot/SB10RD.f @@ -0,0 +1,706 @@ + SUBROUTINE SB10RD( N, M, NP, NCON, NMEAS, GAMMA, A, LDA, B, LDB, + $ C, LDC, D, LDD, F, LDF, H, LDH, TU, LDTU, TY, + $ LDTY, X, LDX, Y, LDY, AK, LDAK, BK, LDBK, CK, + $ LDCK, DK, LDDK, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of an H-infinity (sub)optimal controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C from the state feedback matrix F and output injection matrix H as +C determined by the SLICOT Library routine SB10QD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0. +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0. +C M-NCON >= NMEAS. +C +C GAMMA (input) DOUBLE PRECISION +C The value of gamma. It is assumed that gamma is +C sufficiently large so that the controller is admissible. +C GAMMA >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C F (input) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array must contain the +C state feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,M). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,NP) +C The leading N-by-NP part of this array must contain the +C output injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array must contain the +C control transformation matrix TU, as obtained by the +C SLICOT Library routine SB10PD. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array must contain the +C measurement transformation matrix TY, as obtained by the +C SLICOT Library routine SB10PD. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C X (input) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array must contain the +C matrix X, solution of the X-Riccati equation, as obtained +C by the SLICOT Library routine SB10QD. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (input) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array must contain the +C matrix Y, solution of the Y-Riccati equation, as obtained +C by the SLICOT Library routine SB10QD. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK), where +C LIWORK = max(2*(max(NP,M)-M2-NP2,M2,N),NP2) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(1, M2*NP2 + NP2*NP2 + M2*M2 + +C max(D1*D1 + max(2*D1, (D1+D2)*NP2), +C D2*D2 + max(2*D2, D2*M2), 3*N, +C N*(2*NP2 + M2) + +C max(2*N*M2, M2*NP2 + +C max(M2*M2+3*M2, NP2*(2*NP2+ +C M2+max(NP2,N)))))) +C where D1 = NP1 - M2, D2 = M1 - NP2, +C NP1 = NP - NP2, M1 = M - M2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = max(M1,M2,NP1,NP2), an upper bound is +C max( 1, Q*(3*Q + 3*N + max(2*N, 4*Q + max(Q, N)))). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the controller is not admissible (too small value +C of gamma); +C = 2: if the determinant of Im2 + Tu*D11HAT*Ty*D22 is zero. +C +C METHOD +C +C The routine implements the Glover's and Doyle's formulas [1],[2]. +C +C REFERENCES +C +C [1] Glover, K. and Doyle, J.C. +C State-space formulae for all stabilizing controllers that +C satisfy an Hinf norm bound and relations to risk sensitivity. +C Systems and Control Letters, vol. 11, pp. 167-172, 1988. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Sept. 1999, Oct. 2001. +C +C KEYWORDS +C +C Algebraic Riccati equation, H-infinity optimal control, robust +C control. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDF, LDH, LDTU, LDTY, LDWORK, LDX, LDY, + $ M, N, NCON, NMEAS, NP + DOUBLE PRECISION GAMMA +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ F( LDF, * ), H( LDH, * ), TU( LDTU, * ), + $ TY( LDTY, * ), X( LDX, * ), Y( LDY, * ) +C .. +C .. Local Scalars .. + INTEGER I, ID11, ID12, ID21, IJ, INFO2, IW1, IW2, IW3, + $ IW4, IWB, IWC, IWRK, J, LWAMAX, M1, M2, MINWRK, + $ ND1, ND2, NP1, NP2 + DOUBLE PRECISION ANORM, EPS, RCOND +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRI, DGETRS, DLACPY, + $ DLASET, DPOTRF, DSYCON, DSYRK, DSYTRF, DSYTRS, + $ DTRMM, MA02AD, MB01RX, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( GAMMA.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -18 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -20 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -22 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -28 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -30 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -32 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -34 + ELSE +C +C Compute workspace. +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + MINWRK = MAX( 1, M2*NP2 + NP2*NP2 + M2*M2 + + $ MAX( ND1*ND1 + MAX( 2*ND1, ( ND1 + ND2 )*NP2 ), + $ ND2*ND2 + MAX( 2*ND2, ND2*M2 ), 3*N, + $ N*( 2*NP2 + M2 ) + + $ MAX( 2*N*M2, M2*NP2 + + $ MAX( M2*M2 + 3*M2, NP2*( 2*NP2 + + $ M2 + MAX( NP2, N ) ) ) ) ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -37 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C +C Get the machine precision. +C + EPS = DLAMCH( 'Epsilon' ) +C +C Workspace usage. +C + ID11 = 1 + ID21 = ID11 + M2*NP2 + ID12 = ID21 + NP2*NP2 + IW1 = ID12 + M2*M2 + IW2 = IW1 + ND1*ND1 + IW3 = IW2 + ND1*NP2 + IWRK = IW2 +C +C Set D11HAT := -D1122 . +C + IJ = ID11 + DO 20 J = 1, NP2 + DO 10 I = 1, M2 + DWORK( IJ ) = -D( ND1+I, ND2+J ) + IJ = IJ + 1 + 10 CONTINUE + 20 CONTINUE +C +C Set D21HAT := Inp2 . +C + CALL DLASET( 'Upper', NP2, NP2, ZERO, ONE, DWORK( ID21 ), NP2 ) +C +C Set D12HAT := Im2 . +C + CALL DLASET( 'Lower', M2, M2, ZERO, ONE, DWORK( ID12 ), M2 ) +C +C Compute D11HAT, D21HAT, D12HAT . +C + LWAMAX = 0 + IF( ND1.GT.0 ) THEN + IF( ND2.EQ.0 ) THEN +C +C Compute D21HAT'*D21HAT = Inp2 - D1112'*D1112/gamma^2 . +C + CALL DSYRK( 'U', 'T', NP2, ND1, -ONE/GAMMA**2, D, LDD, ONE, + $ DWORK( ID21 ), NP2 ) + ELSE +C +C Compute gdum = gamma^2*Ind1 - D1111*D1111' . +C + CALL DLASET( 'U', ND1, ND1, ZERO, GAMMA**2, DWORK( IW1 ), + $ ND1 ) + CALL DSYRK( 'U', 'N', ND1, ND2, -ONE, D, LDD, ONE, + $ DWORK( IW1 ), ND1 ) + ANORM = DLANSY( 'I', 'U', ND1, DWORK( IW1 ), ND1, + $ DWORK( IWRK ) ) + CALL DSYTRF( 'U', ND1, DWORK( IW1 ), ND1, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 + CALL DSYCON( 'U', ND1, DWORK( IW1 ), ND1, IWORK, ANORM, + $ RCOND, DWORK( IWRK ), IWORK( ND1+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(gdum)*D1112 . +C + CALL DLACPY( 'Full', ND1, NP2, D( 1, ND2+1 ), LDD, + $ DWORK( IW2 ), ND1 ) + CALL DSYTRS( 'U', ND1, NP2, DWORK( IW1 ), ND1, IWORK, + $ DWORK( IW2 ), ND1, INFO2 ) +C +C Compute D11HAT = -D1121*D1111'*inv(gdum)*D1112 - D1122 . +C + CALL DGEMM( 'T', 'N', ND2, NP2, ND1, ONE, D, LDD, + $ DWORK( IW2 ), ND1, ZERO, DWORK( IW3 ), ND2 ) + CALL DGEMM( 'N', 'N', M2, NP2, ND2, -ONE, D( ND1+1, 1 ), + $ LDD, DWORK( IW3 ), ND2, ONE, DWORK( ID11 ), M2 ) +C +C Compute D21HAT'*D21HAT = Inp2 - D1112'*inv(gdum)*D1112 . +C + CALL MB01RX( 'Left', 'Upper', 'Transpose', NP2, ND1, ONE, + $ -ONE, DWORK( ID21 ), NP2, D( 1, ND2+1 ), LDD, + $ DWORK( IW2 ), ND1, INFO2 ) +C + IW2 = IW1 + ND2*ND2 + IWRK = IW2 +C +C Compute gdum = gamma^2*Ind2 - D1111'*D1111 . +C + CALL DLASET( 'L', ND2, ND2, ZERO, GAMMA**2, DWORK( IW1 ), + $ ND2 ) + CALL DSYRK( 'L', 'T', ND2, ND1, -ONE, D, LDD, ONE, + $ DWORK( IW1 ), ND2 ) + ANORM = DLANSY( 'I', 'L', ND2, DWORK( IW1 ), ND2, + $ DWORK( IWRK ) ) + CALL DSYTRF( 'L', ND2, DWORK( IW1 ), ND2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) + CALL DSYCON( 'L', ND2, DWORK( IW1 ), ND2, IWORK, ANORM, + $ RCOND, DWORK( IWRK ), IWORK( ND2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C +C Compute inv(gdum)*D1121' . +C + CALL MA02AD( 'Full', M2, ND2, D( ND1+1, 1 ), LDD, + $ DWORK( IW2 ), ND2 ) + CALL DSYTRS( 'L', ND2, M2, DWORK( IW1 ), ND2, IWORK, + $ DWORK( IW2 ), ND2, INFO2 ) +C +C Compute D12HAT*D12HAT' = Im2 - D1121*inv(gdum)*D1121' . +C + CALL MB01RX( 'Left', 'Lower', 'NoTranspose', M2, ND2, ONE, + $ -ONE, DWORK( ID12 ), M2, D( ND1+1, 1 ), LDD, + $ DWORK( IW2 ), ND2, INFO2 ) + END IF + ELSE + IF( ND2.GT.0 ) THEN +C +C Compute D12HAT*D12HAT' = Im2 - D1121*D1121'/gamma^2 . +C + CALL DSYRK( 'L', 'N', M2, ND2, -ONE/GAMMA**2, D, LDD, ONE, + $ DWORK( ID12 ), M2 ) + END IF + END IF +C +C Compute D21HAT using Cholesky decomposition. +C + CALL DPOTRF( 'U', NP2, DWORK( ID21 ), NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C +C Compute D12HAT using Cholesky decomposition. +C + CALL DPOTRF( 'L', M2, DWORK( ID12 ), M2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C _ +C Compute Z = In - Y*X/gamma^2 and its LU factorization in AK . +C + IWRK = IW1 + CALL DLASET( 'Full', N, N, ZERO, ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, N, -ONE/GAMMA**2, Y, LDY, X, LDX, + $ ONE, AK, LDAK ) + ANORM = DLANGE( '1', N, N, AK, LDAK, DWORK( IWRK ) ) + CALL DGETRF( N, N, AK, LDAK, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGECON( '1', N, AK, LDAK, ANORM, RCOND, DWORK( IWRK ), + $ IWORK( N+1 ), INFO ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 1 + RETURN + END IF +C + IWB = IW1 + IWC = IWB + N*NP2 + IW1 = IWC + ( M2 + NP2 )*N + IW2 = IW1 + N*M2 +C +C Compute C2' + F12' in BK . +C + DO 40 J = 1, N + DO 30 I = 1, NP2 + BK( J, I ) = C( NP1 + I, J ) + F( ND2 + I, J ) + 30 CONTINUE + 40 CONTINUE +C _ +C Compute the transpose of (C2 + F12)*Z , with Z = inv(Z) . +C + CALL DGETRS( 'Transpose', N, NP2, AK, LDAK, IWORK, BK, LDBK, + $ INFO2 ) +C +C Compute the transpose of F2*Z . +C + CALL MA02AD( 'Full', M2, N, F( M1+1, 1 ), LDF, DWORK( IW1 ), N ) + CALL DGETRS( 'Transpose', N, M2, AK, LDAK, IWORK, DWORK( IW1 ), N, + $ INFO2 ) +C +C Compute the transpose of C1HAT = F2*Z - D11HAT*(C2 + F12)*Z . +C + CALL DGEMM( 'N', 'T', N, M2, NP2, -ONE, BK, LDBK, DWORK( ID11 ), + $ M2, ONE, DWORK( IW1 ), N ) +C +C Compute CHAT . +C + CALL DGEMM( 'N', 'T', M2, N, M2, ONE, TU, LDTU, DWORK( IW1 ), N, + $ ZERO, DWORK( IWC ), M2+NP2 ) + CALL MA02AD( 'Full', N, NP2, BK, LDBK, DWORK( IWC+M2 ), M2+NP2 ) + CALL DTRMM( 'L', 'U', 'N', 'N', NP2, N, -ONE, DWORK( ID21 ), NP2, + $ DWORK( IWC+M2 ), M2+NP2 ) +C +C Compute B2 + H12 . +C + IJ = IW2 + DO 60 J = 1, M2 + DO 50 I = 1, N + DWORK( IJ ) = B( I, M1 + J ) + H( I, ND1 + J ) + IJ = IJ + 1 + 50 CONTINUE + 60 CONTINUE +C +C Compute A + HC in AK . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, H, LDH, C, LDC, ONE, AK, + $ LDAK ) +C +C Compute AHAT = A + HC + (B2 + H12)*C1HAT in AK . +C + CALL DGEMM( 'N', 'T', N, N, M2, ONE, DWORK( IW2 ), N, + $ DWORK( IW1 ), N, ONE, AK, LDAK ) +C +C Compute B1HAT = -H2 + (B2 + H12)*D11HAT in BK . +C + CALL DLACPY( 'Full', N, NP2, H( 1, NP1+1 ), LDH, BK, LDBK ) + CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, DWORK( IW2 ), N, + $ DWORK( ID11 ), M2, -ONE, BK, LDBK ) +C +C Compute the first block of BHAT, BHAT1 . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, + $ DWORK( IWB ), N ) +C +C Compute Tu*D11HAT . +C + CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DWORK( ID11 ), + $ M2, ZERO, DWORK( IW1 ), M2 ) +C +C Compute Tu*D11HAT*Ty in DK . +C + CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK( IW1 ), M2, TY, + $ LDTY, ZERO, DK, LDDK ) +C +C Compute P = Im2 + Tu*D11HAT*Ty*D22 and its condition. +C + IW2 = IW1 + M2*NP2 + IWRK = IW2 + M2*M2 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) + CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, + $ D( NP1+1, M1+1 ), LDD, ONE, DWORK( IW2 ), M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK( IW2 ), M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DGECON( '1', M2, DWORK( IW2 ), M2, ANORM, RCOND, + $ DWORK( IWRK ), IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.EPS ) THEN + INFO = 2 + RETURN + END IF +C +C Find the controller matrix CK, CK = inv(P)*CHAT(1:M2,:) . +C + CALL DLACPY( 'Full', M2, N, DWORK( IWC ), M2+NP2, CK, LDCK ) + CALL DGETRS( 'NoTranspose', M2, N, DWORK( IW2 ), M2, IWORK, CK, + $ LDCK, INFO2 ) +C +C Find the controller matrices AK, BK, and DK, exploiting the +C special structure of the relations. +C +C Compute Q = Inp2 + D22*Tu*D11HAT*Ty and its LU factorization. +C + IW3 = IW2 + NP2*NP2 + IW4 = IW3 + NP2*M2 + IWRK = IW4 + NP2*NP2 + CALL DLASET( 'Full', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, M2, ONE, D( NP1+1, M1+1 ), LDD, + $ DK, LDDK, ONE, DWORK( IW2 ), NP2 ) + CALL DGETRF( NP2, NP2, DWORK( IW2 ), NP2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C +C Compute A1 = inv(Q)*D22 and inv(Q) . +C + CALL DLACPY( 'Full', NP2, M2, D( NP1+1, M1+1 ), LDD, DWORK( IW3 ), + $ NP2 ) + CALL DGETRS( 'NoTranspose', NP2, M2, DWORK( IW2 ), NP2, IWORK, + $ DWORK( IW3 ), NP2, INFO2 ) + CALL DGETRI( NP2, DWORK( IW2 ), NP2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute A2 = ( inv(Ty) - inv(Q)*inv(Ty) - +C A1*Tu*D11HAT )*inv(D21HAT) . +C + CALL DLACPY( 'Full', NP2, NP2, TY, LDTY, DWORK( IW4 ), NP2 ) + CALL DGETRF( NP2, NP2, DWORK( IW4 ), NP2, IWORK, INFO2 ) + CALL DGETRI( NP2, DWORK( IW4 ), NP2, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) +C + CALL DLACPY( 'Full', NP2, NP2, DWORK( IW4 ), NP2, DWORK( IWRK ), + $ NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, NP2, -ONE, DWORK( IW2), NP2, + $ DWORK( IWRK ), NP2, ONE, DWORK( IW4 ), NP2 ) + CALL DGEMM( 'N', 'N', NP2, NP2, M2, -ONE, DWORK( IW3), NP2, + $ DWORK( IW1 ), M2, ONE, DWORK( IW4 ), NP2 ) + CALL DTRMM( 'R', 'U', 'N', 'N', NP2, NP2, ONE, DWORK( ID21 ), NP2, + $ DWORK( IW4 ), NP2 ) +C +C Compute [ A1 A2 ]*CHAT . +C + CALL DGEMM( 'N', 'N', NP2, N, M2+NP2, ONE, DWORK( IW3 ), NP2, + $ DWORK( IWC ), M2+NP2, ZERO, DWORK( IWRK ), NP2 ) +C +C Compute AK := AHAT - BHAT1*[ A1 A2 ]*CHAT . +C + CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, DWORK( IWB ), N, + $ DWORK( IWRK ), NP2, ONE, AK, LDAK ) +C +C Compute BK := BHAT1*inv(Q) . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, DWORK( IWB ), N, + $ DWORK( IW2 ), NP2, ZERO, BK, LDBK ) +C +C Compute DK := Tu*D11HAT*Ty*inv(Q) . +C + CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DK, LDDK, DWORK( IW2 ), + $ NP2, ZERO, DWORK( IW3 ), M2 ) + CALL DLACPY( 'Full', M2, NP2, DWORK( IW3 ), M2, DK, LDDK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10RD *** + END diff --git a/mex/sources/libslicot/SB10SD.f b/mex/sources/libslicot/SB10SD.f new file mode 100644 index 000000000..ee99c78f2 --- /dev/null +++ b/mex/sources/libslicot/SB10SD.f @@ -0,0 +1,629 @@ + SUBROUTINE SB10SD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ X, LDX, Y, LDY, RCOND, TOL, IWORK, DWORK, + $ LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C for the normalized discrete-time system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | D11 D12 | | C | D | +C | C2 | D21 0 | +C +C where B2 has as column size the number of control inputs (NCON) +C and C2 has as row size the number of measurements (NMEAS) being +C provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank with D12 = | 0 | and D21 is +C | I | +C full row rank with D21 = | 0 I | as obtained by the +C SLICOT Library routine SB10PD, +C +C j*Theta +C (A3) | A-e *I B2 | has full column rank for all +C | C1 D12 | +C +C 0 <= Theta < 2*Pi , +C +C +C j*Theta +C (A4) | A-e *I B1 | has full row rank for all +C | C2 D21 | +C +C 0 <= Theta < 2*Pi . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. Only the leading +C (NP-NP2)-by-(M-M2) submatrix D11 is used. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the matrix +C Y, solution of the Y-Riccati equation. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C RCOND (output) DOUBLE PRECISION array, dimension (4) +C RCOND contains estimates of the reciprocal condition +C numbers of the matrices which are to be inverted and the +C reciprocal condition numbers of the Riccati equations +C which have to be solved during the computation of the +C controller. (See the description of the algorithm in [2].) +C RCOND(1) contains the reciprocal condition number of the +C matrix Im2 + B2'*X2*B2; +C RCOND(2) contains the reciprocal condition number of the +C matrix Ip2 + C2*Y2*C2'; +C RCOND(3) contains the reciprocal condition number of the +C X-Riccati equation; +C RCOND(4) contains the reciprocal condition number of the +C Y-Riccati equation. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used in determining the nonsingularity of the +C matrices which must be inverted. If TOL <= 0, then a +C default value equal to sqrt(EPS) is used, where EPS is the +C relative machine precision. +C +C Workspace +C +C IWORK INTEGER array, dimension max(M2,2*N,N*N,NP2) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(1, 14*N*N+6*N+max(14*N+23,16*N), +C M2*(N+M2+max(3,M1)), NP2*(N+NP2+3)), +C where M1 = M - M2. +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the X-Riccati equation was not solved +C successfully; +C = 2: if the matrix Im2 + B2'*X2*B2 is not positive +C definite, or it is numerically singular (with +C respect to the tolerance TOL); +C = 3: if the Y-Riccati equation was not solved +C successfully; +C = 4: if the matrix Ip2 + C2*Y2*C2' is not positive +C definite, or it is numerically singular (with +C respect to the tolerance TOL). +C +C METHOD +C +C The routine implements the formulas given in [1]. The X- and +C Y-Riccati equations are solved with condition estimates. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C matrices which are to be inverted and on the condition numbers of +C the matrix Riccati equations which are to be solved in the +C computation of the controller. (The corresponding reciprocal +C condition numbers are given in the output array RCOND.) +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C January 2003. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, LDX, LDY, M, N, NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( * ), X( LDX, * ), Y( LDY, * ) + LOGICAL BWORK( * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IW2, IWB, IWC, IWG, IWI, IWQ, IWR, IWRK, + $ IWS, IWT, IWU, IWV, J, LWAMAX, M1, M2, MINWRK, + $ ND1, ND2, NP1, NP2 + DOUBLE PRECISION ANORM, FERR, RCOND2, SEPD, TOLL +C .. +C .. External functions .. + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL DLAMCH, DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DPOCON, DPOTRF, DPOTRS, + $ DSWAP, DSYRK, DTRSM, MB01RX, SB02OD, SB02SD, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -21 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -23 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -25 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, 14*N*N + 6*N + MAX( 14*N + 23, 16*N ), + $ M2*( N + M2 + MAX( 3, M1 ) ), NP2*( N + NP2 + 3 ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -30 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10SD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for nonsingularity test. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Workspace usage. +C + IWQ = 1 + IWG = IWQ + N*N + IWR = IWG + N*N + IWI = IWR + 2*N + IWB = IWI + 2*N + IWS = IWB + 2*N + IWT = IWS + 4*N*N + IWU = IWT + 4*N*N + IWRK = IWU + 4*N*N + IWC = IWR + IWV = IWC + N*N +C +C Compute Ax = A - B2*D12'*C1 in AK . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, + $ C( ND1+1, 1), LDC, ONE, AK, LDAK ) +C +C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . +C + IF( ND1.GT.0 ) THEN + CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), + $ N ) + ELSE + CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + END IF +C +C Compute Dx = B2*B2' . +C + CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, + $ DWORK( IWG ), N ) +C +C Solution of the discrete-time Riccati equation +C Ax'*inv(In + X2*Dx)*X2*Ax - X2 + Cx = 0 . +C Workspace: need 14*N*N + 6*N + max(14*N+23,16*N); +C prefer larger. +C + CALL SB02OD( 'D', 'G', 'N', 'L', 'Z', 'S', N, M2, NP1, AK, LDAK, + $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, + $ DWORK( IWRK ), N, RCOND2, X, LDX, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, + $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Condition estimation. +C Workspace: need 4*N*N + max(N*N+5*N,max(3,2*N*N)+N*N); +C prefer larger. +C + IWRK = IWV + N*N + CALL SB02SD( 'C', 'N', 'N', 'L', 'O', N, AK, LDAK, DWORK( IWC ), + $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ X, LDX, SEPD, RCOND( 3 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 3 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IW2 = M2*N + 1 + IWRK = IW2 + M2*M2 +C +C Compute B2'*X2 . +C + CALL DGEMM( 'T', 'N', M2, N, N, ONE, B( 1, M1+1 ), LDB, X, LDX, + $ ZERO, DWORK, M2 ) +C +C Compute Im2 + B2'*X2*B2 . +C + CALL DLASET( 'L', M2, M2, ZERO, ONE, DWORK( IW2 ), M2 ) + CALL MB01RX( 'Left', 'Lower', 'N', M2, N, ONE, ONE, DWORK( IW2 ), + $ M2, DWORK, M2, B( 1, M1+1 ), LDB, INFO2 ) +C +C Compute the Cholesky factorization of Im2 + B2'*X2*B2 . +C Workspace: need M2*N + M2*M2 + max(3*M2,M2*M1); +C prefer larger. +C + ANORM = DLANSY( 'I', 'L', M2, DWORK( IW2 ), M2, DWORK( IWRK ) ) + CALL DPOTRF( 'L', M2, DWORK( IW2 ), M2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF + CALL DPOCON( 'L', M2, DWORK( IW2 ), M2, ANORM, RCOND( 1 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 1 ).LT.TOLL ) THEN + INFO = 2 + RETURN + END IF +C +C Compute -( B2'*X2*A + D12'*C1 ) in CK . +C + CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, CK, LDCK ) + CALL DGEMM( 'N', 'N', M2, N, N, -ONE, DWORK, M2, A, LDA, -ONE, CK, + $ LDCK ) +C +C Compute F2 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*A + D12'*C1 ) . +C + CALL DPOTRS( 'L', M2, N, DWORK( IW2 ), M2, CK, LDCK, INFO2 ) +C +C Compute -( B2'*X2*B1 + D12'*D11 ) . +C + CALL DLACPY( 'Full', M2, M1, D( ND1+1, 1 ), LDD, DWORK( IWRK ), + $ M2 ) + CALL DGEMM( 'N', 'N', M2, M1, N, -ONE, DWORK, M2, B, LDB, -ONE, + $ DWORK( IWRK ), M2 ) +C +C Compute F0 = -inv( Im2 + B2'*X2*B2 )*( B2'*X2*B1 + D12'*D11 ) . +C + CALL DPOTRS( 'L', M2, M1, DWORK( IW2 ), M2, DWORK( IWRK ), M2, + $ INFO2 ) +C +C Save F0*D21' in DK . +C + CALL DLACPY( 'Full', M2, NP2, DWORK( IWRK+ND2*M2 ), M2, DK, + $ LDDK ) +C +C Workspace usage. +C + IWRK = IWU + 4*N*N +C +C Compute Ay = A - B1*D21'*C2 in AK . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, + $ C( NP1+1, 1 ), LDC, ONE, AK, LDAK ) +C +C Transpose Ay in-situ. +C + DO 20 J = 1, N - 1 + CALL DSWAP( J, AK( J+1, 1 ), LDAK, AK( 1, J+1 ), 1 ) + 20 CONTINUE +C +C Compute Cy = B1*B1' - B1*D21'*D21*B1' . +C + IF( ND2.GT.0 ) THEN + CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), + $ N ) + ELSE + CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + END IF +C +C Compute Dy = C2'*C2 . +C + CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, + $ DWORK( IWG ), N ) +C +C Solution of the discrete-time Riccati equation +C Ay*inv( In + Y2*Dy )*Y2*Ay' - Y2 + Cy = 0 . +C + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, NP2, M1, AK, LDAK, + $ DWORK( IWG ), N, DWORK( IWQ ), N, DWORK( IWRK ), M, + $ DWORK( IWRK ), N, RCOND2, Y, LDY, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWB ), DWORK( IWS ), 2*N, + $ DWORK( IWT ), 2*N, DWORK( IWU ), 2*N, TOLL, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Condition estimation. +C + IWRK = IWV + N*N + CALL SB02SD( 'C', 'N', 'N', 'U', 'O', N, AK, LDAK, DWORK( IWC ), + $ N, DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Y, LDY, SEPD, RCOND( 4 ), FERR, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.GT.0 ) RCOND( 4 ) = ZERO + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Workspace usage. +C + IW2 = N*NP2 + 1 + IWRK = IW2 + NP2*NP2 +C +C Compute Y2*C2' . +C + CALL DGEMM( 'N', 'T', N, NP2, N, ONE, Y, LDY, C( NP1+1, 1 ), LDC, + $ ZERO, DWORK, N ) +C +C Compute Ip2 + C2*Y2*C2' . +C + CALL DLASET( 'U', NP2, NP2, ZERO, ONE, DWORK( IW2 ), NP2 ) + CALL MB01RX( 'Left', 'Upper', 'N', NP2, N, ONE, ONE, DWORK( IW2 ), + $ NP2, C( NP1+1, 1 ), LDC, DWORK, N, INFO2 ) +C +C Compute the Cholesky factorization of Ip2 + C2*Y2*C2' . +C + ANORM = DLANSY( 'I', 'U', NP2, DWORK( IW2 ), NP2, DWORK( IWRK ) ) + CALL DPOTRF( 'U', NP2, DWORK( IW2 ), NP2, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DPOCON( 'U', NP2, DWORK( IW2 ), NP2, ANORM, RCOND( 2 ), + $ DWORK( IWRK ), IWORK, INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 2 ).LT.TOLL ) THEN + INFO = 4 + RETURN + END IF +C +C Compute A*Y2*C2' + B1*D21' in BK . +C + CALL DLACPY ( 'Full', N, NP2, B( 1, ND2+1 ), LDB, BK, LDBK ) + CALL DGEMM( 'N', 'N', N, NP2, N, ONE, A, LDA, DWORK, N, ONE, + $ BK, LDBK ) +C +C Compute L2 = -( A*Y2*C2' + B1*D21' )*inv( Ip2 + C2*Y2*C2' ) . +C + CALL DTRSM( 'R', 'U', 'N', 'N', N, NP2, -ONE, DWORK( IW2 ), NP2, + $ BK, LDBK ) + CALL DTRSM( 'R', 'U', 'T', 'N', N, NP2, ONE, DWORK( IW2 ), NP2, + $ BK, LDBK ) +C +C Compute F2*Y2*C2' + F0*D21' . +C + CALL DGEMM( 'N', 'N', M2, NP2, N, ONE, CK, LDCK, DWORK, N, ONE, + $ DK, LDDK ) +C +C Compute DK = L0 = ( F2*Y2*C2' + F0*D21' )*inv( Ip2 + C2*Y2*C2' ) . +C + CALL DTRSM( 'R', 'U', 'N', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, + $ DK, LDDK ) + CALL DTRSM( 'R', 'U', 'T', 'N', M2, NP2, ONE, DWORK( IW2 ), NP2, + $ DK, LDDK ) +C +C Compute CK = F2 - L0*C2 . +C + CALL DGEMM( 'N', 'N', M2, N, NP2, -ONE, DK, LDDK, C( NP1+1, 1), + $ LDC, ONE, CK, LDCK ) +C +C Find AK = A + B2*( F2 - L0*C2 ) + L2*C2 . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M2, ONE, B(1, M1+1 ), LDB, CK, LDCK, + $ ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP2, ONE, BK, LDBK, C( NP1+1, 1), + $ LDC, ONE, AK, LDAK ) +C +C Find BK = -L2 + B2*L0 . +C + CALL DGEMM( 'N', 'N', N, NP2, M2, ONE, B( 1, M1+1 ), LDB, DK, + $ LDDK, -ONE, BK, LDBK ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10SD *** + END diff --git a/mex/sources/libslicot/SB10TD.f b/mex/sources/libslicot/SB10TD.f new file mode 100644 index 000000000..e8d193b41 --- /dev/null +++ b/mex/sources/libslicot/SB10TD.f @@ -0,0 +1,350 @@ + SUBROUTINE SB10TD( N, M, NP, NCON, NMEAS, D, LDD, TU, LDTU, TY, + $ LDTY, AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, + $ RCOND, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal discrete-time controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C from the matrices of the controller for the normalized system, +C as determined by the SLICOT Library routine SB10SD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0. +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0. +C M-NCON >= NMEAS. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. Only the trailing +C NMEAS-by-NCON submatrix D22 is used. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array must contain the +C control transformation matrix TU, as obtained by the +C SLICOT Library routine SB10PD. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array must contain the +C measurement transformation matrix TY, as obtained by the +C SLICOT Library routine SB10PD. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C AK (input/output) DOUBLE PRECISION array, dimension (LDAK,N) +C On entry, the leading N-by-N part of this array must +C contain controller state matrix for the normalized system +C as obtained by the SLICOT Library routine SB10SD. +C On exit, the leading N-by-N part of this array contains +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (input/output) DOUBLE PRECISION array, dimension +C (LDBK,NMEAS) +C On entry, the leading N-by-NMEAS part of this array must +C contain controller input matrix for the normalized system +C as obtained by the SLICOT Library routine SB10SD. +C On exit, the leading N-by-NMEAS part of this array +C contains controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (input/output) DOUBLE PRECISION array, dimension (LDCK,N) +C On entry, the leading NCON-by-N part of this array must +C contain controller output matrix for the normalized +C system as obtained by the SLICOT Library routine SB10SD. +C On exit, the leading NCON-by-N part of this array contains +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (input/output) DOUBLE PRECISION array, dimension +C (LDDK,NMEAS) +C On entry, the leading NCON-by-NMEAS part of this array +C must contain controller matrix DK for the normalized +C system as obtained by the SLICOT Library routine SB10SD. +C On exit, the leading NCON-by-NMEAS part of this array +C contains controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C RCOND (output) DOUBLE PRECISION +C RCOND contains an estimate of the reciprocal condition +C number of the matrix Im2 + DKHAT*D22 which must be +C inverted in the computation of the controller. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used in determining the nonsingularity of the +C matrix which must be inverted. If TOL <= 0, then a default +C value equal to sqrt(EPS) is used, where EPS is the +C relative machine precision. +C +C Workspace +C +C IWORK INTEGER array, dimension (2*M2) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= max(N*M2,N*NP2,M2*NP2,M2*M2+4*M2). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix Im2 + DKHAT*D22 is singular, or the +C estimated condition number is larger than or equal +C to 1/TOL. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Petkov, P.Hr., Gu, D.W., and Konstantinov, M.M. +C Fortran 77 routines for Hinf and H2 design of linear +C discrete-time control systems. +C Report 99-8, Department of Engineering, Leicester University, +C April 1999. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations and of the matrix Im2 + +C DKHAT*D22. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, April 1999. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Jan. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDAK, LDBK, LDCK, LDD, LDDK, LDTU, LDTY, + $ LDWORK, M, N, NCON, NMEAS, NP + DOUBLE PRECISION RCOND, TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION AK( LDAK, * ), BK( LDBK, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ TU( LDTU, * ), TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWRK, M1, M2, MINWRK, NP1, NP2 + DOUBLE PRECISION ANORM, TOLL +C .. +C .. External Functions + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE +C .. +C .. External Subroutines .. + EXTERNAL DGECON, DGEMM, DGETRF, DGETRS, DLACPY, DLASET, + $ XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -7 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -9 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -11 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -17 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE +C +C Compute workspace. +C + MINWRK = MAX ( N*M2, N*NP2, M2*NP2, M2*( M2 + 4 ) ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -24 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +C + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for nonsingularity test. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Find BKHAT . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, ONE, BK, LDBK, TY, LDTY, ZERO, + $ DWORK, N ) + CALL DLACPY ('Full', N, NP2, DWORK, N, BK, LDBK ) +C +C Find CKHAT . +C + CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, CK, LDCK, ZERO, + $ DWORK, M2 ) + CALL DLACPY ('Full', M2, N, DWORK, M2, CK, LDCK ) +C +C Compute DKHAT . +C + CALL DGEMM( 'N', 'N', M2, NP2, M2, ONE, TU, LDTU, DK, LDDK, ZERO, + $ DWORK, M2 ) + CALL DGEMM( 'N', 'N', M2, NP2, NP2, ONE, DWORK, M2, TY, LDTY, + $ ZERO, DK, LDDK ) +C +C Compute Im2 + DKHAT*D22 . +C + IWRK = M2*M2 + 1 + CALL DLASET( 'Full', M2, M2, ZERO, ONE, DWORK, M2 ) + CALL DGEMM( 'N', 'N', M2, M2, NP2, ONE, DK, LDDK, + $ D( NP1+1, M1+1 ), LDD, ONE, DWORK, M2 ) + ANORM = DLANGE( '1', M2, M2, DWORK, M2, DWORK( IWRK ) ) + CALL DGETRF( M2, M2, DWORK, M2, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF + CALL DGECON( '1', M2, DWORK, M2, ANORM, RCOND, DWORK( IWRK ), + $ IWORK( M2+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND.LT.TOLL ) THEN + INFO = 1 + RETURN + END IF +C +C Compute CK . +C + CALL DGETRS( 'N', M2, N, DWORK, M2, IWORK, CK, LDCK, INFO2 ) +C +C Compute DK . +C + CALL DGETRS( 'N', M2, NP2, DWORK, M2, IWORK, DK, LDDK, INFO2 ) +C +C Compute AK . +C + CALL DGEMM( 'N', 'N', N, M2, NP2, ONE, BK, LDBK, D( NP1+1, M1+1 ), + $ LDD, ZERO, DWORK, N ) + CALL DGEMM( 'N', 'N', N, N, M2, -ONE, DWORK, N, CK, LDCK, ONE, AK, + $ LDAK ) +C +C Compute BK . +C + CALL DGEMM( 'N', 'N', N, NP2, M2, -ONE, DWORK, N, DK, LDDK, + $ ONE, BK, LDBK ) + RETURN +C *** Last line of SB10TD *** + END diff --git a/mex/sources/libslicot/SB10UD.f b/mex/sources/libslicot/SB10UD.f new file mode 100644 index 000000000..b5919d442 --- /dev/null +++ b/mex/sources/libslicot/SB10UD.f @@ -0,0 +1,419 @@ + SUBROUTINE SB10UD( N, M, NP, NCON, NMEAS, B, LDB, C, LDC, D, LDD, + $ TU, LDTU, TY, LDTY, RCOND, TOL, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the matrices D12 and D21 of the linear time-invariant +C system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | 0 D12 | | C | D | +C | C2 | D21 D22 | +C +C to unit diagonal form, and to transform the matrices B and C to +C satisfy the formulas in the computation of the H2 optimal +C controller. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading NP-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading NP-by-N part of this array contains +C the transformed system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading NP-by-M part of this array must +C contain the system input/output matrix D. +C The (NP-NMEAS)-by-(M-NCON) leading submatrix D11 is not +C referenced. +C On exit, the trailing NMEAS-by-NCON part (in the leading +C NP-by-M part) of this array contains the transformed +C submatrix D22. +C The transformed submatrices D12 = [ 0 Im2 ]' and +C D21 = [ 0 Inp2 ] are not stored. The corresponding part +C of this array contains no useful information. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C TU (output) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array contains the +C control transformation matrix TU. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (output) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array contains the +C measurement transformation matrix TY. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C RCOND (output) DOUBLE PRECISION array, dimension (2) +C RCOND(1) contains the reciprocal condition number of the +C control transformation matrix TU; +C RCOND(2) contains the reciprocal condition number of the +C measurement transformation matrix TY. +C RCOND is set even if INFO = 1 or INFO = 2; if INFO = 1, +C then RCOND(2) was not computed, but it is set to 0. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for controlling the accuracy of the applied +C transformations. Transformation matrices TU and TY whose +C reciprocal condition numbers are less than TOL are not +C allowed. If TOL <= 0, then a default value equal to +C sqrt(EPS) is used, where EPS is the relative machine +C precision. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX( M2 + NP1*NP1 + MAX(NP1*N,3*M2+NP1,5*M2), +C NP2 + M1*M1 + MAX(M1*N,3*NP2+M1,5*NP2), +C N*M2, NP2*N, NP2*M2, 1 ) +C where M1 = M - M2 and NP1 = NP - NP2. +C For good performance, LDWORK must generally be larger. +C Denoting Q = MAX(M1,M2,NP1,NP2), an upper bound is +C MAX(1,Q*(Q+MAX(N,5)+1)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the matrix D12 had not full column rank in +C respect to the tolerance TOL; +C = 2: if the matrix D21 had not full row rank in respect +C to the tolerance TOL; +C = 3: if the singular value decomposition (SVD) algorithm +C did not converge (when computing the SVD of D12 or +C D21). +C +C METHOD +C +C The routine performs the transformations described in [1], [2]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The precision of the transformations can be controlled by the +C condition numbers of the matrices TU and TY as given by the +C values of RCOND(1) and RCOND(2), respectively. An error return +C with INFO = 1 or INFO = 2 will be obtained if the condition +C number of TU or TY, respectively, would exceed 1/TOL. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999, +C Feb. 2000. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDB, LDC, LDD, LDTU, LDTY, LDWORK, M, N, + $ NCON, NMEAS, NP + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + DOUBLE PRECISION B( LDB, * ), C( LDC, * ), D( LDD, * ), + $ DWORK( * ), RCOND( 2 ), TU( LDTU, * ), + $ TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IQ, IWRK, J, LWAMAX, M1, M2, MINWRK, + $ ND1, ND2, NP1, NP2 + DOUBLE PRECISION TOLL +C .. +C .. External Functions + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DGESVD, DLACPY, DSCAL, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -13 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -15 + ELSE +C +C Compute workspace. +C + MINWRK = MAX( 1, M2 + NP1*NP1 + MAX( NP1*N, 3*M2 + NP1, + $ 5*M2 ), + $ NP2 + M1*M1 + MAX( M1*N, 3*NP2 + M1, 5*NP2 ), + $ N*M2, NP2*N, NP2*M2 ) + IF( LDWORK.LT.MINWRK ) + $ INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10UD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + TOLL = TOL + IF( TOLL.LE.ZERO ) THEN +C +C Set the default value of the tolerance for condition tests. +C + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + END IF +C +C Determine SVD of D12, D12 = U12 S12 V12', and check if D12 has +C full column rank. V12' is stored in TU. +C Workspace: need M2 + NP1*NP1 + max(3*M2+NP1,5*M2); +C prefer larger. +C + IQ = M2 + 1 + IWRK = IQ + NP1*NP1 +C + CALL DGESVD( 'A', 'A', NP1, M2, D( 1, M1+1 ), LDD, DWORK, + $ DWORK( IQ ), NP1, TU, LDTU, DWORK( IWRK ), + $ LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C + RCOND( 1 ) = DWORK( M2 )/DWORK( 1 ) + IF( RCOND( 1 ).LE.TOLL ) THEN + RCOND( 2 ) = ZERO + INFO = 1 + RETURN + END IF + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Determine Q12. +C + IF( ND1.GT.0 ) THEN + CALL DLACPY( 'Full', NP1, M2, DWORK( IQ ), NP1, D( 1, M1+1 ), + $ LDD ) + CALL DLACPY( 'Full', NP1, ND1, DWORK( IQ+NP1*M2 ), NP1, + $ DWORK( IQ ), NP1 ) + CALL DLACPY( 'Full', NP1, M2, D( 1, M1+1 ), LDD, + $ DWORK( IQ+NP1*ND1 ), NP1 ) + END IF +C +C Determine Tu by transposing in-situ and scaling. +C + DO 10 J = 1, M2 - 1 + CALL DSWAP( J, TU( J+1, 1 ), LDTU, TU( 1, J+1 ), 1 ) + 10 CONTINUE +C + DO 20 J = 1, M2 + CALL DSCAL( M2, ONE/DWORK( J ), TU( 1, J ), 1 ) + 20 CONTINUE +C +C Determine C1 =: Q12'*C1. +C Workspace: M2 + NP1*NP1 + NP1*N. +C + CALL DGEMM( 'T', 'N', NP1, N, NP1, ONE, DWORK( IQ ), NP1, C, LDC, + $ ZERO, DWORK( IWRK ), NP1 ) + CALL DLACPY( 'Full', NP1, N, DWORK( IWRK ), NP1, C, LDC ) + LWAMAX = MAX( IWRK + NP1*N - 1, LWAMAX ) +C +C Determine SVD of D21, D21 = U21 S21 V21', and check if D21 has +C full row rank. U21 is stored in TY. +C Workspace: need NP2 + M1*M1 + max(3*NP2+M1,5*NP2); +C prefer larger. +C + IQ = NP2 + 1 + IWRK = IQ + M1*M1 +C + CALL DGESVD( 'A', 'A', NP2, M1, D( NP1+1, 1 ), LDD, DWORK, TY, + $ LDTY, DWORK( IQ ), M1, DWORK( IWRK ), LDWORK-IWRK+1, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C + RCOND( 2 ) = DWORK( NP2 )/DWORK( 1 ) + IF( RCOND( 2 ).LE.TOLL ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Determine Q21. +C + IF( ND2.GT.0 ) THEN + CALL DLACPY( 'Full', NP2, M1, DWORK( IQ ), M1, D( NP1+1, 1 ), + $ LDD ) + CALL DLACPY( 'Full', ND2, M1, DWORK( IQ+NP2 ), M1, DWORK( IQ ), + $ M1 ) + CALL DLACPY( 'Full', NP2, M1, D( NP1+1, 1 ), LDD, + $ DWORK( IQ+ND2 ), M1 ) + END IF +C +C Determine Ty by scaling and transposing in-situ. +C + DO 30 J = 1, NP2 + CALL DSCAL( NP2, ONE/DWORK( J ), TY( 1, J ), 1 ) + 30 CONTINUE +C + DO 40 J = 1, NP2 - 1 + CALL DSWAP( J, TY( J+1, 1 ), LDTY, TY( 1, J+1 ), 1 ) + 40 CONTINUE +C +C Determine B1 =: B1*Q21'. +C Workspace: NP2 + M1*M1 + N*M1. +C + CALL DGEMM( 'N', 'T', N, M1, M1, ONE, B, LDB, DWORK( IQ ), M1, + $ ZERO, DWORK( IWRK ), N ) + CALL DLACPY( 'Full', N, M1, DWORK( IWRK ), N, B, LDB ) + LWAMAX = MAX( IWRK + N*M1 - 1, LWAMAX ) +C +C Determine B2 =: B2*Tu. +C Workspace: N*M2. +C + CALL DGEMM( 'N', 'N', N, M2, M2, ONE, B( 1, M1+1 ), LDB, TU, LDTU, + $ ZERO, DWORK, N ) + CALL DLACPY( 'Full', N, M2, DWORK, N, B( 1, M1+1 ), LDB ) +C +C Determine C2 =: Ty*C2. +C Workspace: NP2*N. +C + CALL DGEMM( 'N', 'N', NP2, N, NP2, ONE, TY, LDTY, + $ C( NP1+1, 1 ), LDC, ZERO, DWORK, NP2 ) + CALL DLACPY( 'Full', NP2, N, DWORK, NP2, C( NP1+1, 1 ), LDC ) +C +C Determine D22 =: Ty*D22*Tu. +C Workspace: NP2*M2. +C + CALL DGEMM( 'N', 'N', NP2, M2, NP2, ONE, TY, LDTY, + $ D( NP1+1, M1+1 ), LDD, ZERO, DWORK, NP2 ) + CALL DGEMM( 'N', 'N', NP2, M2, M2, ONE, DWORK, NP2, TU, LDTU, + $ ZERO, D( NP1+1, M1+1 ), LDD ) +C + LWAMAX = MAX( N*MAX( M2, NP2 ), NP2*M2, LWAMAX ) + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10UD *** + END diff --git a/mex/sources/libslicot/SB10VD.f b/mex/sources/libslicot/SB10VD.f new file mode 100644 index 000000000..913a5ab29 --- /dev/null +++ b/mex/sources/libslicot/SB10VD.f @@ -0,0 +1,393 @@ + SUBROUTINE SB10VD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ F, LDF, H, LDH, X, LDX, Y, LDY, XYCOND, IWORK, + $ DWORK, LDWORK, BWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the state feedback and the output injection +C matrices for an H2 optimal n-state controller for the system +C +C | A | B1 B2 | | A | B | +C P = |----|---------| = |---|---| +C | C1 | 0 D12 | | C | D | +C | C2 | D21 D22 | +C +C where B2 has as column size the number of control inputs (NCON) +C and C2 has as row size the number of measurements (NMEAS) being +C provided to the controller. +C +C It is assumed that +C +C (A1) (A,B2) is stabilizable and (C2,A) is detectable, +C +C (A2) D12 is full column rank with D12 = | 0 | and D21 is +C | I | +C full row rank with D21 = | 0 I | as obtained by the +C SLICOT Library routine SB10UD. Matrix D is not used +C explicitly. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0, +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0, +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C F (output) DOUBLE PRECISION array, dimension (LDF,N) +C The leading NCON-by-N part of this array contains the +C state feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,NCON). +C +C H (output) DOUBLE PRECISION array, dimension (LDH,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C output injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C The leading N-by-N part of this array contains the matrix +C X, solution of the X-Riccati equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= max(1,N). +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,N) +C The leading N-by-N part of this array contains the matrix +C Y, solution of the Y-Riccati equation. +C +C LDY INTEGER +C The leading dimension of the array Y. LDY >= max(1,N). +C +C XYCOND (output) DOUBLE PRECISION array, dimension (2) +C XYCOND(1) contains an estimate of the reciprocal condition +C number of the X-Riccati equation; +C XYCOND(2) contains an estimate of the reciprocal condition +C number of the Y-Riccati equation. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2*N,N*N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal +C LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 13*N*N + 12*N + 5. +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the X-Riccati equation was not solved +C successfully; +C = 2: if the Y-Riccati equation was not solved +C successfully. +C +C METHOD +C +C The routine implements the formulas given in [1], [2]. The X- +C and Y-Riccati equations are solved with condition and accuracy +C estimates [3]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V. +C DGRSVX and DMSRIC: Fortan 77 subroutines for solving +C continuous-time matrix algebraic Riccati equations with +C condition and accuracy estimates. +C Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ. +C Chemnitz, May 1998. +C +C NUMERICAL ASPECTS +C +C The precision of the solution of the matrix Riccati equations +C can be controlled by the values of the condition numbers +C XYCOND(1) and XYCOND(2) of these equations. +C +C FURTHER COMMENTS +C +C The Riccati equations are solved by the Schur approach +C implementing condition and accuracy estimates. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDF, LDH, LDWORK, LDX, + $ LDY, M, N, NCON, NMEAS, NP +C .. +C .. Array Arguments .. + LOGICAL BWORK( * ) + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), F( LDF, * ), H( LDH, * ), + $ X( LDX, * ), XYCOND( 2 ), Y( LDY, * ) +C .. +C .. Local Scalars .. + INTEGER INFO2, IWG, IWI, IWQ, IWR, IWRK, IWS, IWT, IWV, + $ LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, NP1, NP2 + DOUBLE PRECISION FERR, SEP +C .. +C .. External Functions .. +C + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, DSYRK, SB02RD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDF.LT.MAX( 1, NCON ) ) THEN + INFO = -13 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDY.LT.MAX( 1, N ) ) THEN + INFO = -19 + ELSE +C +C Compute workspace. +C + MINWRK = 13*N*N + 12*N + 5 + IF( LDWORK.LT.MINWRK ) + $ INFO = -23 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10VD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN + DWORK( 1 ) = ONE + XYCOND( 1 ) = ONE + XYCOND( 2 ) = ONE + RETURN + END IF +C + ND1 = NP1 - M2 + ND2 = M1 - NP2 + N2 = 2*N +C +C Workspace usage. +C + IWQ = N*N + 1 + IWG = IWQ + N*N + IWT = IWG + N*N + IWV = IWT + N*N + IWR = IWV + N*N + IWI = IWR + N2 + IWS = IWI + N2 + IWRK = IWS + 4*N*N +C +C Compute Ax = A - B2*D12'*C1 . +C + CALL DLACPY ('Full', N, N, A, LDA, DWORK, N ) + CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB, + $ C( ND1+1, 1), LDC, ONE, DWORK, N ) +C +C Compute Cx = C1'*C1 - C1'*D12*D12'*C1 . +C + IF( ND1.GT.0 ) THEN + CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ), + $ N ) + ELSE + CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + END IF +C +C Compute Dx = B2*B2' . +C + CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO, + $ DWORK( IWG ), N ) +C +C Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 . +C Workspace: need 13*N*N + 12*N + 5; +C prefer larger. +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose', + $ 'Lower', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK, N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 1 + RETURN + END IF +C + LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1 +C +C Compute F = -D12'*C1 - B2'*X . +C + CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, F, LDF ) + CALL DGEMM( 'T', 'N', M2, N, N, -ONE, B( 1, M1+1 ), LDB, X, LDX, + $ -ONE, F, LDF ) +C +C Compute Ay = A - B1*D21'*C2 . +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N ) + CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB, + $ C( NP1+1, 1 ), LDC, ONE, DWORK, N ) +C +C Compute Cy = B1*B1' - B1*D21'*D21*B1' . +C + IF( ND2.GT.0 ) THEN + CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ), + $ N ) + ELSE + CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N ) + END IF +C +C Compute Dy = C2'*C2 . +C + CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO, + $ DWORK( IWG ), N ) +C +C Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 . +C Workspace: need 13*N*N + 12*N + 5; +C prefer larger. +C + CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose', + $ 'Upper', 'GeneralScaling', 'Stable', 'NotFactored', + $ 'Original', N, DWORK, N, DWORK( IWT ), N, + $ DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N, + $ Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ), + $ DWORK( IWI ), DWORK( IWS ), N2, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 2 + RETURN + END IF +C + LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX ) +C +C Compute H = -B1*D21' - Y*C2' . +C + CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, H, LDH ) + CALL DGEMM( 'N', 'T', N, NP2, N, -ONE, Y, LDY, C( NP1+1, 1 ), LDC, + $ -ONE, H, LDH ) +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10VD *** + END diff --git a/mex/sources/libslicot/SB10WD.f b/mex/sources/libslicot/SB10WD.f new file mode 100644 index 000000000..e2f37b2f3 --- /dev/null +++ b/mex/sources/libslicot/SB10WD.f @@ -0,0 +1,299 @@ + SUBROUTINE SB10WD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC, + $ D, LDD, F, LDF, H, LDH, TU, LDTU, TY, LDTY, + $ AK, LDAK, BK, LDBK, CK, LDCK, DK, LDDK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the H2 optimal controller +C +C | AK | BK | +C K = |----|----|, +C | CK | DK | +C +C from the state feedback matrix F and output injection matrix H as +C determined by the SLICOT Library routine SB10VD. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C NCON (input) INTEGER +C The number of control inputs (M2). M >= NCON >= 0. +C NP-NMEAS >= NCON. +C +C NMEAS (input) INTEGER +C The number of measurements (NP2). NP >= NMEAS >= 0. +C M-NCON >= NMEAS. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B. Only the submatrix +C B2 = B(:,M-M2+1:M) is used. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C. Only the submatrix +C C2 = C(NP-NP2+1:NP,:) is used. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D. Only the submatrix +C D22 = D(NP-NP2+1:NP,M-M2+1:M) is used. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C F (input) DOUBLE PRECISION array, dimension (LDF,N) +C The leading NCON-by-N part of this array must contain the +C state feedback matrix F. +C +C LDF INTEGER +C The leading dimension of the array F. LDF >= max(1,NCON). +C +C H (input) DOUBLE PRECISION array, dimension (LDH,NMEAS) +C The leading N-by-NMEAS part of this array must contain the +C output injection matrix H. +C +C LDH INTEGER +C The leading dimension of the array H. LDH >= max(1,N). +C +C TU (input) DOUBLE PRECISION array, dimension (LDTU,M2) +C The leading M2-by-M2 part of this array must contain the +C control transformation matrix TU, as obtained by the +C SLICOT Library routine SB10UD. +C +C LDTU INTEGER +C The leading dimension of the array TU. LDTU >= max(1,M2). +C +C TY (input) DOUBLE PRECISION array, dimension (LDTY,NP2) +C The leading NP2-by-NP2 part of this array must contain the +C measurement transformation matrix TY, as obtained by the +C SLICOT Library routine SB10UD. +C +C LDTY INTEGER +C The leading dimension of the array TY. +C LDTY >= max(1,NP2). +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix AK. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NMEAS) +C The leading N-by-NMEAS part of this array contains the +C controller input matrix BK. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading NCON-by-N part of this array contains the +C controller output matrix CK. +C +C LDCK INTEGER +C The leading dimension of the array CK. +C LDCK >= max(1,NCON). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NMEAS) +C The leading NCON-by-NMEAS part of this array contains the +C controller input/output matrix DK. +C +C LDDK INTEGER +C The leading dimension of the array DK. +C LDDK >= max(1,NCON). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine implements the formulas given in [1], [2]. +C +C REFERENCES +C +C [1] Zhou, K., Doyle, J.C., and Glover, K. +C Robust and Optimal Control. +C Prentice-Hall, Upper Saddle River, NJ, 1996. +C +C [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and +C Smith, R. +C mu-Analysis and Synthesis Toolbox. +C The MathWorks Inc., Natick, Mass., 1995. +C +C NUMERICAL ASPECTS +C +C The accuracy of the result depends on the condition numbers of the +C input and output transformations. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 1999. +C +C KEYWORDS +C +C Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal +C regulator, robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDF, LDH, LDTU, LDTY, M, N, NCON, NMEAS, + $ NP +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AK( LDAK, * ), B( LDB, * ), + $ BK( LDBK, * ), C( LDC, * ), CK( LDCK, * ), + $ D( LDD, * ), DK( LDDK, * ), F( LDF, * ), + $ H( LDH, * ), TU( LDTU, * ), TY( LDTY, * ) +C .. +C .. Local Scalars .. + INTEGER M1, M2, NP1, NP2 +C .. +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, DLASET, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + M1 = M - NCON + M2 = NCON + NP1 = NP - NMEAS + NP2 = NMEAS +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN + INFO = -4 + ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -13 + ELSE IF( LDF.LT.MAX( 1, M2 ) ) THEN + INFO = -15 + ELSE IF( LDH.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDTU.LT.MAX( 1, M2 ) ) THEN + INFO = -19 + ELSE IF( LDTY.LT.MAX( 1, NP2 ) ) THEN + INFO = -21 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -23 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -25 + ELSE IF( LDCK.LT.MAX( 1, M2 ) ) THEN + INFO = -27 + ELSE IF( LDDK.LT.MAX( 1, M2 ) ) THEN + INFO = -29 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0 + $ .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) RETURN +C +C Compute the transpose of D22*F . BK is used as workspace. +C + CALL DGEMM( 'T', 'T', N, NP2, M2, ONE, F, LDF, D( NP1+1, M1+1 ), + $ LDD, ZERO, BK, LDBK ) +C +C Find AK = A + H*C2 + B2*F + H*D22*F . +C + CALL DLACPY( 'Full', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP2, ONE, H, LDH, C( NP1+1, 1 ), LDC, + $ ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M2, ONE, B( 1, M1+1 ), LDB, + $ F, LDF, ONE, AK, LDAK ) + CALL DGEMM( 'N', 'T', N, N, NP2, ONE, H, LDH, BK, LDBK, ONE, AK, + $ LDAK ) +C +C Find BK = -H*Ty . +C + CALL DGEMM( 'N', 'N', N, NP2, NP2, -ONE, H, LDH, TY, LDTY, ZERO, + $ BK, LDBK ) +C +C Find CK = Tu*F . +C + CALL DGEMM( 'N', 'N', M2, N, M2, ONE, TU, LDTU, F, LDF, ZERO, CK, + $ LDCK ) +C +C Find DK . +C + CALL DLASET( 'Full', M2, NP2, ZERO, ZERO, DK, LDDK ) +C + RETURN +C *** Last line of SB10WD *** + END diff --git a/mex/sources/libslicot/SB10YD.f b/mex/sources/libslicot/SB10YD.f new file mode 100644 index 000000000..fa84e9f01 --- /dev/null +++ b/mex/sources/libslicot/SB10YD.f @@ -0,0 +1,689 @@ + SUBROUTINE SB10YD( DISCFL, FLAG, LENDAT, RFRDAT, IFRDAT, OMEGA, N, + $ A, LDA, B, C, D, TOL, IWORK, DWORK, LDWORK, + $ ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To fit a supplied frequency response data with a stable, minimum +C phase SISO (single-input single-output) system represented by its +C matrices A, B, C, D. It handles both discrete- and continuous-time +C cases. +C +C ARGUMENTS +C +C Input/Output parameters +C +C DISCFL (input) INTEGER +C Indicates the type of the system, as follows: +C = 0: continuous-time system; +C = 1: discrete-time system. +C +C FLAG (input) INTEGER +C If FLAG = 0, then the system zeros and poles are not +C constrained. +C If FLAG = 1, then the system zeros and poles will have +C negative real parts in the continuous-time case, or moduli +C less than 1 in the discrete-time case. Consequently, FLAG +C must be equal to 1 in mu-synthesis routines. +C +C LENDAT (input) INTEGER +C The length of the vectors RFRDAT, IFRDAT and OMEGA. +C LENDAT >= 2. +C +C RFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) +C The real part of the frequency data to be fitted. +C +C IFRDAT (input) DOUBLE PRECISION array, dimension (LENDAT) +C The imaginary part of the frequency data to be fitted. +C +C OMEGA (input) DOUBLE PRECISION array, dimension (LENDAT) +C The frequencies corresponding to RFRDAT and IFRDAT. +C These values must be nonnegative and monotonically +C increasing. Additionally, for discrete-time systems +C they must be between 0 and PI. +C +C N (input/output) INTEGER +C On entry, the desired order of the system to be fitted. +C N <= LENDAT-1. +C On exit, the order of the obtained system. The value of N +C could only be modified if N > 0 and FLAG = 1. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the +C matrix A. If FLAG = 1, then A is in an upper Hessenberg +C form, and corresponds to a minimal realization. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (N) +C The computed vector B. +C +C C (output) DOUBLE PRECISION array, dimension (N) +C The computed vector C. If FLAG = 1, the first N-1 elements +C are zero (for the exit value of N). +C +C D (output) DOUBLE PRECISION array, dimension (1) +C The computed scalar D. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used for determining the effective +C rank of matrices. If the user sets TOL > 0, then the given +C value of TOL is used as a lower bound for the reciprocal +C condition number; a (sub)matrix whose estimated condition +C number is less than 1/TOL is considered to be of full +C rank. If the user sets TOL <= 0, then an implicitly +C computed, default tolerance, defined by TOLDEF = SIZE*EPS, +C is used instead, where SIZE is the product of the matrix +C dimensions, and EPS is the machine precision (see LAPACK +C Library routine DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension max(2,2*N+1) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK and DWORK(2) contains the optimal value of +C LZWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK = max( 2, LW1, LW2, LW3, LW4 ), where +C LW1 = 2*LENDAT + 4*HNPTS; HNPTS = 2048; +C LW2 = LENDAT + 6*HNPTS; +C MN = min( 2*LENDAT, 2*N+1 ) +C LW3 = 2*LENDAT*(2*N+1) + max( 2*LENDAT, 2*N+1 ) + +C max( MN + 6*N + 4, 2*MN + 1 ), if N > 0; +C LW3 = 4*LENDAT + 5 , if N = 0; +C LW4 = max( N*N + 5*N, 6*N + 1 + min( 1,N ) ), if FLAG = 1; +C LW4 = 0, if FLAG = 0. +C For optimum performance LDWORK should be larger. +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK = LENDAT*(2*N+3), if N > 0; +C LZWORK = LENDAT, if N = 0. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the discrete --> continuous transformation cannot +C be made; +C = 2: if the system poles cannot be found; +C = 3: if the inverse system cannot be found, i.e., D is +C (close to) zero; +C = 4: if the system zeros cannot be found; +C = 5: if the state-space representation of the new +C transfer function T(s) cannot be found; +C = 6: if the continuous --> discrete transformation cannot +C be made. +C +C METHOD +C +C First, if the given frequency data are corresponding to a +C continuous-time system, they are changed to a discrete-time +C system using a bilinear transformation with a scaled alpha. +C Then, the magnitude is obtained from the supplied data. +C Then, the frequency data are linearly interpolated around +C the unit-disc. +C Then, Oppenheim and Schafer complex cepstrum method is applied +C to get frequency data corresponding to a stable, minimum- +C phase system. This is done in the following steps: +C - Obtain LOG (magnitude) +C - Obtain IFFT of the result (DG01MD SLICOT subroutine); +C - halve the data at 0; +C - Obtain FFT of the halved data (DG01MD SLICOT subroutine); +C - Obtain EXP of the result. +C Then, the new frequency data are interpolated back to the +C original frequency. +C Then, based on these newly obtained data, the system matrices +C A, B, C, D are constructed; the very identification is +C performed by Least Squares Method using DGELSY LAPACK subroutine. +C If needed, a discrete-to-continuous time transformation is +C applied on the system matrices by AB04MD SLICOT subroutine. +C Finally, if requested, the poles and zeros of the system are +C checked. If some of them have positive real parts in the +C continuous-time case (or are not inside the unit disk in the +C complex plane in the discrete-time case), they are exchanged with +C their negatives (or reciprocals, respectively), to preserve the +C frequency response, while getting a minimum phase and stable +C system. This is done by SB10ZP SLICOT subroutine. +C +C REFERENCES +C +C [1] Oppenheim, A.V. and Schafer, R.W. +C Discrete-Time Signal Processing. +C Prentice-Hall Signal Processing Series, 1989. +C +C [2] Balas, G., Doyle, J., Glover, K., Packard, A., and Smith, R. +C Mu-analysis and Synthesis toolbox - User's Guide, +C The Mathworks Inc., Natick, MA, USA, 1998. +C +C CONTRIBUTORS +C +C Asparuh Markovski, Technical University of Sofia, July 2003. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. +C A. Markovski, Technical University of Sofia, October 2003. +C +C KEYWORDS +C +C Bilinear transformation, frequency response, least-squares +C approximation, stability. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ZZERO, ZONE + PARAMETER ( ZZERO = ( 0.0D+0, 0.0D+0 ), + $ ZONE = ( 1.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION ZERO, ONE, TWO, FOUR, TEN + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ FOUR = 4.0D+0, TEN = 1.0D+1 ) + INTEGER HNPTS + PARAMETER ( HNPTS = 2048 ) +C .. +C .. Scalar Arguments .. + INTEGER DISCFL, FLAG, INFO, LDA, LDWORK, LENDAT, + $ LZWORK, N + DOUBLE PRECISION TOL +C .. +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA, *), B(*), C(*), D(*), DWORK(*), + $ IFRDAT(*), OMEGA(*), RFRDAT(*) + COMPLEX*16 ZWORK(*) +C .. +C .. Local Scalars .. + INTEGER CLWMAX, DLWMAX, I, II, INFO2, IP1, IP2, ISTART, + $ ISTOP, IWA0, IWAB, IWBMAT, IWBP, IWBX, IWDME, + $ IWDOMO, IWMAG, IWS, IWVAR, IWXI, IWXR, IWYMAG, + $ K, LW1, LW2, LW3, LW4, MN, N1, N2, P, RANK + DOUBLE PRECISION P1, P2, PI, PW, RAT, TOLB, TOLL + COMPLEX*16 XHAT(HNPTS/2) +C .. +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +C .. +C .. External Subroutines .. + EXTERNAL AB04MD, DCOPY, DG01MD, DGELSY, DLASET, DSCAL, + $ SB10ZP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ACOS, ATAN, COS, DBLE, DCMPLX, DIMAG, EXP, LOG, + $ MAX, MIN, SIN, SQRT +C +C Test input parameters and workspace. +C + PI = FOUR*ATAN( ONE ) + PW = OMEGA(1) + N1 = N + 1 + N2 = N + N1 +C + INFO = 0 + IF( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN + INFO = -1 + ELSE IF( FLAG.NE.0 .AND. FLAG.NE.1 ) THEN + INFO = -2 + ELSE IF ( LENDAT.LT.2 ) THEN + INFO = -3 + ELSE IF ( PW.LT.ZERO ) THEN + INFO = -6 + ELSE IF( N.GT.LENDAT - 1 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE +C + DO 10 K = 2, LENDAT + IF ( OMEGA(K).LT.PW ) + $ INFO = -6 + PW = OMEGA(K) + 10 CONTINUE +C + IF ( DISCFL.EQ.1 .AND. OMEGA(LENDAT).GT.PI ) + $ INFO = -6 + END IF +C + IF ( INFO.EQ.0 ) THEN +C +C Workspace. +C + LW1 = 2*LENDAT + 4*HNPTS + LW2 = LENDAT + 6*HNPTS + MN = MIN( 2*LENDAT, N2 ) +C + IF ( N.GT.0 ) THEN + LW3 = 2*LENDAT*N2 + MAX( 2*LENDAT, N2 ) + + $ MAX( MN + 6*N + 4, 2*MN + 1 ) + ELSE + LW3 = 4*LENDAT + 5 + END IF +C + IF ( FLAG.EQ.0 ) THEN + LW4 = 0 + ELSE + LW4 = MAX( N*N + 5*N, 6*N + 1 + MIN ( 1, N ) ) + END IF +C + DLWMAX = MAX( 2, LW1, LW2, LW3, LW4 ) +C + IF ( N.GT.0 ) THEN + CLWMAX = LENDAT*( N2 + 2 ) + ELSE + CLWMAX = LENDAT + END IF +C + IF ( LDWORK.LT.DLWMAX ) THEN + INFO = -16 + ELSE IF ( LZWORK.LT.CLWMAX ) THEN + INFO = -18 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB10YD', -INFO ) + RETURN + END IF +C +C Set tolerances. +C + TOLB = DLAMCH( 'Epsilon' ) + TOLL = TOL + IF ( TOLL.LE.ZERO ) + $ TOLL = FOUR*DBLE( LENDAT*N )*TOLB +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Workspace usage 1. +C Workspace: need 2*LENDAT + 4*HNPTS. +C + IWDOMO = 1 + IWDME = IWDOMO + LENDAT + IWYMAG = IWDME + 2*HNPTS + IWMAG = IWYMAG + 2*HNPTS +C +C Bilinear transformation. +C + IF ( DISCFL.EQ.0 ) THEN + PW = SQRT( OMEGA(1)*OMEGA(LENDAT) + SQRT( TOLB ) ) +C + DO 20 K = 1, LENDAT + DWORK(IWDME+K-1) = ( OMEGA(K)/PW )**2 + DWORK(IWDOMO+K-1) = + $ ACOS( ( ONE - DWORK(IWDME+K-1) )/ + $ ( ONE + DWORK(IWDME+K-1) ) ) + 20 CONTINUE +C + ELSE + CALL DCOPY( LENDAT, OMEGA, 1, DWORK(IWDOMO), 1 ) + END IF +C +C Linear interpolation. +C + DO 30 K = 1, LENDAT + DWORK(IWMAG+K-1) = DLAPY2( RFRDAT(K), IFRDAT(K) ) + DWORK(IWMAG+K-1) = ( ONE/LOG( TEN ) ) * LOG( DWORK(IWMAG+K-1) ) + 30 CONTINUE +C + DO 40 K = 1, HNPTS + DWORK(IWDME+K-1) = ( K - 1 )*PI/HNPTS + DWORK(IWYMAG+K-1) = ZERO +C + IF ( DWORK(IWDME+K-1).LT.DWORK(IWDOMO) ) THEN + DWORK(IWYMAG+K-1) = DWORK(IWMAG) + ELSE IF ( DWORK(IWDME+K-1).GE.DWORK(IWDOMO+LENDAT-1) ) THEN + DWORK(IWYMAG+K-1) = DWORK(IWMAG+LENDAT-1) + END IF +C + 40 CONTINUE +C + DO 60 I = 2, LENDAT + P1 = HNPTS*DWORK(IWDOMO+I-2)/PI + ONE +C + IP1 = INT( P1 ) + IF ( DBLE( IP1 ).NE.P1 ) + $ IP1 = IP1 + 1 +C + P2 = HNPTS*DWORK(IWDOMO+I-1)/PI + ONE +C + IP2 = INT( P2 ) + IF ( DBLE( IP2 ).NE.P2 ) + $ IP2 = IP2 + 1 +C + DO 50 P = IP1, IP2 - 1 + RAT = DWORK(IWDME+P-1) - DWORK(IWDOMO+I-2) + RAT = RAT/( DWORK(IWDOMO+I-1) - DWORK(IWDOMO+I-2) ) + DWORK(IWYMAG+P-1) = ( ONE - RAT )*DWORK(IWMAG+I-2) + + $ RAT*DWORK(IWMAG+I-1) + 50 CONTINUE +C + 60 CONTINUE +C + DO 70 K = 1, HNPTS + DWORK(IWYMAG+K-1) = EXP( LOG( TEN )*DWORK(IWYMAG+K-1) ) + 70 CONTINUE +C +C Duplicate data around disc. +C + DO 80 K = 1, HNPTS + DWORK(IWDME+HNPTS+K-1) = TWO*PI - DWORK(IWDME+HNPTS-K) + DWORK(IWYMAG+HNPTS+K-1) = DWORK(IWYMAG+HNPTS-K) + 80 CONTINUE +C +C Complex cepstrum to get min phase: +C LOG (Magnitude) +C + DO 90 K = 1, 2*HNPTS + DWORK(IWYMAG+K-1) = TWO*LOG( DWORK(IWYMAG+K-1) ) + 90 CONTINUE +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Workspace usage 2. +C Workspace: need LENDAT + 6*HNPTS. +C + IWXR = IWYMAG + IWXI = IWMAG +C + DO 100 K = 1, 2*HNPTS + DWORK(IWXI+K-1) = ZERO + 100 CONTINUE +C +C IFFT +C + CALL DG01MD( 'I', 2*HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) +C +C Rescale, because DG01MD doesn't do it. +C + CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXR), 1 ) + CALL DSCAL( HNPTS, ONE/( TWO*HNPTS ), DWORK(IWXI), 1 ) +C +C Halve the result at 0. +C + DWORK(IWXR) = DWORK(IWXR)/TWO + DWORK(IWXI) = DWORK(IWXI)/TWO +C +C FFT +C + CALL DG01MD( 'D', HNPTS, DWORK(IWXR), DWORK(IWXI), INFO2 ) +C +C Get the EXP of the result. +C + DO 110 K = 1, HNPTS/2 + XHAT(K) = EXP( DWORK(IWXR+K-1) )* + $ DCMPLX ( COS( DWORK(IWXI+K-1)), SIN( DWORK(IWXI+K-1) ) ) + DWORK(IWDME+K-1) = DWORK(IWDME+2*K-2) + 110 CONTINUE +C +C Interpolate back to original frequency data. +C + ISTART = 1 + ISTOP = LENDAT +C + DO 120 I = 1, LENDAT + ZWORK(I) = ZZERO + IF ( DWORK(IWDOMO+I-1).LE.DWORK(IWDME) ) THEN + ZWORK(I) = XHAT(1) + ISTART = I + 1 + ELSE IF ( DWORK(IWDOMO+I-1).GE.DWORK(IWDME+HNPTS/2-1) ) + $ THEN + ZWORK(I) = XHAT(HNPTS/2) + ISTOP = ISTOP - 1 + END IF + 120 CONTINUE +C + DO 140 I = ISTART, ISTOP + II = HNPTS/2 + 130 CONTINUE + IF ( DWORK(IWDME+II-1).GE.DWORK(IWDOMO+I-1) ) + $ P = II + II = II - 1 + IF ( II.GT.0 ) + $ GOTO 130 + RAT = ( DWORK(IWDOMO+I-1) - DWORK(IWDME+P-2) )/ + $ ( DWORK(IWDME+P-1) - DWORK(IWDME+P-2) ) + ZWORK(I) = RAT*XHAT(P) + ( ONE - RAT )*XHAT(P-1) + 140 CONTINUE +C +C CASE N > 0. +C This is the only allowed case in mu-synthesis subroutines. +C + IF ( N.GT.0 ) THEN +C +C Preparation for frequency identification. +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Complex workspace usage 1. +C Complex workspace: need 2*LENDAT + LENDAT*(N+1). +C + IWA0 = 1 + LENDAT + IWVAR = IWA0 + LENDAT*N1 +C + DO 150 K = 1, LENDAT + IF ( DISCFL.EQ.0 ) THEN + ZWORK(IWVAR+K-1) = DCMPLX( COS( DWORK(IWDOMO+K-1) ), + $ SIN( DWORK(IWDOMO+K-1) ) ) + ELSE + ZWORK(IWVAR+K-1) = DCMPLX( COS( OMEGA(K) ), + $ SIN( OMEGA(K) ) ) + END IF + 150 CONTINUE +C +C Array for DGELSY. +C + DO 160 K = 1, N2 + IWORK(K) = 0 + 160 CONTINUE +C +C Constructing A0. +C + DO 170 K = 1, LENDAT + ZWORK(IWA0+N*LENDAT+K-1) = ZONE + 170 CONTINUE +C + DO 190 I = 1, N + DO 180 K = 1, LENDAT + ZWORK(IWA0+(N-I)*LENDAT+K-1) = + $ ZWORK(IWA0+(N1-I)*LENDAT+K-1)*ZWORK(IWVAR+K-1) + 180 CONTINUE + 190 CONTINUE +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Complex workspace usage 2. +C Complex workspace: need 2*LENDAT + LENDAT*(2*N+1). +C + IWBP = IWVAR + IWAB = IWBP + LENDAT +C +C Constructing BP. +C + DO 200 K = 1, LENDAT + ZWORK(IWBP+K-1) = ZWORK(IWA0+K-1)*ZWORK(K) + 200 CONTINUE +C +C Constructing AB. +C + DO 220 I = 1, N + DO 210 K = 1, LENDAT + ZWORK(IWAB+(I-1)*LENDAT+K-1) = -ZWORK(K)* + $ ZWORK(IWA0+I*LENDAT+K-1) + 210 CONTINUE + 220 CONTINUE +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Workspace usage 3. +C Workspace: need LW3 = 2*LENDAT*(2*N+1) + max(2*LENDAT,2*N+1). +C + IWBX = 1 + 2*LENDAT*N2 + IWS = IWBX + MAX( 2*LENDAT, N2 ) +C +C Constructing AX. +C + DO 240 I = 1, N1 + DO 230 K = 1, LENDAT + DWORK(2*(I-1)*LENDAT+K) = + $ DBLE( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) + DWORK((2*I-1)*LENDAT+K) = + $ DIMAG( ZWORK(IWA0+(I-1)*LENDAT+K-1) ) + 230 CONTINUE + 240 CONTINUE +C + DO 260 I = 1, N + DO 250 K = 1, LENDAT + DWORK(2*N1*LENDAT+2*(I-1)*LENDAT+K) = + $ DBLE( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) + DWORK(2*N1*LENDAT+(2*I-1)*LENDAT+K) = + $ DIMAG( ZWORK(IWAB+(I-1)*LENDAT+K-1) ) + 250 CONTINUE + 260 CONTINUE +C +C Constructing BX. +C + DO 270 K = 1, LENDAT + DWORK(IWBX+K-1) = DBLE( ZWORK(IWBP+K-1) ) + DWORK(IWBX+LENDAT+K-1) = DIMAG( ZWORK(IWBP+K-1) ) + 270 CONTINUE +C +C Estimating X. +C Workspace: need LW3 + max( MN+3*(2*N+1)+1, 2*MN+1 ), +C where MN = min( 2*LENDAT, 2*N+1 ); +C prefer larger. +C + CALL DGELSY( 2*LENDAT, N2, 1, DWORK, 2*LENDAT, DWORK(IWBX), + $ MAX( 2*LENDAT, N2 ), IWORK, TOLL, RANK, + $ DWORK(IWS), LDWORK-IWS+1, INFO2 ) + DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) +C +C Constructing A matrix. +C + DO 280 K = 1, N + A(K,1) = -DWORK(IWBX+N1+K-1) + 280 CONTINUE +C + IF ( N.GT.1 ) + $ CALL DLASET( 'Full', N, N-1, ZERO, ONE, A(1,2), LDA ) +C +C Constructing B matrix. +C + DO 290 K = 1, N + B(K) = DWORK(IWBX+N1+K-1)*DWORK(IWBX) - DWORK(IWBX+K) + 290 CONTINUE +C +C Constructing C matrix. +C + C(1) = -ONE +C + DO 300 K = 2, N + C(K) = ZERO + 300 CONTINUE +C +C Constructing D matrix. +C + D(1) = DWORK(IWBX) +C +C Transform to continuous-time case, if needed. +C Workspace: need max(1,N); +C prefer larger. +C + IF ( DISCFL.EQ.0 ) THEN + CALL AB04MD( 'D', N, 1, 1, ONE, PW, A, LDA, B, LDA, C, 1, + $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) + END IF +C +C Make all the real parts of the poles and the zeros negative. +C + IF ( FLAG.EQ.1 ) THEN +C +C Workspace: need max(N*N + 5*N, 6*N + 1 + min(1,N)); +C prefer larger. + CALL SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, + $ LDWORK, INFO ) + IF ( INFO.NE.0 ) + $ RETURN + DLWMAX = MAX( DLWMAX, INT( DWORK(1) ) ) + END IF +C + ELSE +C +C CASE N = 0. +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C +C Workspace usage 4. +C Workspace: need 4*LENDAT. +C + IWBMAT = 1 + 2*LENDAT + IWS = IWBMAT + 2*LENDAT +C +C Constructing AMAT and BMAT. +C + DO 310 K = 1, LENDAT + DWORK(K) = ONE + DWORK(K+LENDAT) = ZERO + DWORK(IWBMAT+K-1) = DBLE( ZWORK(K) ) + DWORK(IWBMAT+LENDAT+K-1) = DIMAG( ZWORK(K) ) + 310 CONTINUE +C +C Estimating D matrix. +C Workspace: need 4*LENDAT + 5; +C prefer larger. +C + IWORK(1) = 0 + CALL DGELSY( 2*LENDAT, 1, 1, DWORK, 2*LENDAT, DWORK(IWBMAT), + $ 2*LENDAT, IWORK, TOLL, RANK, DWORK(IWS), + $ LDWORK-IWS+1, INFO2 ) + DLWMAX = MAX( DLWMAX, INT( DWORK(IWS) + IWS - 1 ) ) +C + D(1) = DWORK(IWBMAT) +C + END IF +C +C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +C + DWORK(1) = DLWMAX + DWORK(2) = CLWMAX + RETURN +C +C *** Last line of SB10YD *** + END diff --git a/mex/sources/libslicot/SB10ZD.f b/mex/sources/libslicot/SB10ZD.f new file mode 100644 index 000000000..f70c834dd --- /dev/null +++ b/mex/sources/libslicot/SB10ZD.f @@ -0,0 +1,914 @@ + SUBROUTINE SB10ZD( N, M, NP, A, LDA, B, LDB, C, LDC, D, LDD, + $ FACTOR, AK, LDAK, BK, LDBK, CK, LDCK, DK, + $ LDDK, RCOND, TOL, IWORK, DWORK, LDWORK, BWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the matrices of the positive feedback controller +C +C | Ak | Bk | +C K = |----|----| +C | Ck | Dk | +C +C for the shaped plant +C +C | A | B | +C G = |---|---| +C | C | D | +C +C in the Discrete-Time Loop Shaping Design Procedure. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the plant. N >= 0. +C +C M (input) INTEGER +C The column size of the matrix B. M >= 0. +C +C NP (input) INTEGER +C The row size of the matrix C. NP >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C system state matrix A of the shaped plant. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C system input matrix B of the shaped plant. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= max(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading NP-by-N part of this array must contain the +C system output matrix C of the shaped plant. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= max(1,NP). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading NP-by-M part of this array must contain the +C system input/output matrix D of the shaped plant. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= max(1,NP). +C +C FACTOR (input) DOUBLE PRECISION +C = 1 implies that an optimal controller is required +C (not recommended); +C > 1 implies that a suboptimal controller is required +C achieving a performance FACTOR less than optimal. +C FACTOR >= 1. +C +C AK (output) DOUBLE PRECISION array, dimension (LDAK,N) +C The leading N-by-N part of this array contains the +C controller state matrix Ak. +C +C LDAK INTEGER +C The leading dimension of the array AK. LDAK >= max(1,N). +C +C BK (output) DOUBLE PRECISION array, dimension (LDBK,NP) +C The leading N-by-NP part of this array contains the +C controller input matrix Bk. +C +C LDBK INTEGER +C The leading dimension of the array BK. LDBK >= max(1,N). +C +C CK (output) DOUBLE PRECISION array, dimension (LDCK,N) +C The leading M-by-N part of this array contains the +C controller output matrix Ck. +C +C LDCK INTEGER +C The leading dimension of the array CK. LDCK >= max(1,M). +C +C DK (output) DOUBLE PRECISION array, dimension (LDDK,NP) +C The leading M-by-NP part of this array contains the +C controller matrix Dk. +C +C LDDK INTEGER +C The leading dimension of the array DK. LDDK >= max(1,M). +C +C RCOND (output) DOUBLE PRECISION array, dimension (6) +C RCOND(1) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the P-Riccati equation is +C obtained; +C RCOND(2) contains an estimate of the reciprocal condition +C number of the linear system of equations from +C which the solution of the Q-Riccati equation is +C obtained; +C RCOND(3) contains an estimate of the reciprocal condition +C number of the matrix (gamma^2-1)*In - P*Q; +C RCOND(4) contains an estimate of the reciprocal condition +C number of the matrix Rx + Bx'*X*Bx; +C RCOND(5) contains an estimate of the reciprocal condition +C ^ +C number of the matrix Ip + D*Dk; +C RCOND(6) contains an estimate of the reciprocal condition +C ^ +C number of the matrix Im + Dk*D. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C Tolerance used for checking the nonsingularity of the +C matrices to be inverted. If TOL <= 0, then a default value +C equal to sqrt(EPS) is used, where EPS is the relative +C machine precision. TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension 2*max(N,M+NP) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + +C 7*N*NP + 6*N + 2*(M + NP) + +C max(14*N+23,16*N,2*M-1,2*NP-1). +C For good performance, LDWORK must generally be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Error Indicator +C +C INFO (output) INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the P-Riccati equation is not solved successfully; +C = 2: the Q-Riccati equation is not solved successfully; +C = 3: the iteration to compute eigenvalues or singular +C values failed to converge; +C = 4: the matrix (gamma^2-1)*In - P*Q is singular; +C = 5: the matrix Rx + Bx'*X*Bx is singular; +C ^ +C = 6: the matrix Ip + D*Dk is singular; +C ^ +C = 7: the matrix Im + Dk*D is singular; +C = 8: the matrix Ip - D*Dk is singular; +C = 9: the matrix Im - Dk*D is singular; +C = 10: the closed-loop system is unstable. +C +C METHOD +C +C The routine implements the formulas given in [1]. +C +C REFERENCES +C +C [1] Gu, D.-W., Petkov, P.H., and Konstantinov, M.M. +C On discrete H-infinity loop shaping design procedure routines. +C Technical Report 00-6, Dept. of Engineering, Univ. of +C Leicester, UK, 2000. +C +C NUMERICAL ASPECTS +C +C The accuracy of the results depends on the conditioning of the +C two Riccati equations solved in the controller design. For +C better conditioning it is advised to take FACTOR > 1. +C +C CONTRIBUTORS +C +C P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, May 2001. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 2001. +C +C KEYWORDS +C +C H_infinity control, Loop-shaping design, Robust control. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDAK, LDB, LDBK, LDC, LDCK, LDD, + $ LDDK, LDWORK, M, N, NP + DOUBLE PRECISION FACTOR, TOL +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + LOGICAL BWORK( * ) + DOUBLE PRECISION A ( LDA, * ), AK( LDAK, * ), B ( LDB, * ), + $ BK( LDBK, * ), C ( LDC, * ), CK( LDCK, * ), + $ D ( LDD, * ), DK( LDDK, * ), DWORK( * ), + $ RCOND( 6 ) +C .. +C .. Local Scalars .. + INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9, I10, + $ I11, I12, I13, I14, I15, I16, I17, I18, I19, + $ I20, I21, I22, I23, I24, I25, I26, INFO2, IWRK, + $ J, LWAMAX, MINWRK, N2, NS, SDIM + DOUBLE PRECISION ANORM, GAMMA, TOLL +C .. +C .. External Functions .. + LOGICAL SELECT + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY, DLAPY2 + EXTERNAL DLAMCH, DLANGE, DLANSY, DLAPY2, SELECT +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DGECON, DGEES, DGEMM, DGETRF, DGETRS, + $ DLACPY, DLASCL, DLASET, DPOTRF, DPOTRS, DSWAP, + $ DSYCON, DSYEV, DSYRK, DSYTRF, DSYTRS, DTRSM, + $ DTRTRS, MA02AD, MB01RX, MB02VD, SB02OD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Decode and Test input parameters. +C + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( NP.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, NP ) ) THEN + INFO = -11 + ELSE IF( FACTOR.LT.ONE ) THEN + INFO = -12 + ELSE IF( LDAK.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDBK.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDCK.LT.MAX( 1, M ) ) THEN + INFO = -18 + ELSE IF( LDDK.LT.MAX( 1, M ) ) THEN + INFO = -20 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -22 + END IF +C +C Compute workspace. +C + MINWRK = 16*N*N + 5*M*M + 7*NP*NP + 6*M*N + 7*M*NP + 7*N*NP + + $ 6*N + 2*(M + NP) + MAX( 14*N+23, 16*N, 2*M-1, 2*NP-1 ) + IF( LDWORK.LT.MINWRK ) THEN + INFO = -25 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SB10ZD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C Note that some computation could be made if one or two of the +C dimension parameters N, M, and P are zero, but the results are +C not so meaningful. +C + IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 ) THEN + RCOND( 1 ) = ONE + RCOND( 2 ) = ONE + RCOND( 3 ) = ONE + RCOND( 4 ) = ONE + RCOND( 5 ) = ONE + RCOND( 6 ) = ONE + DWORK( 1 ) = ONE + RETURN + END IF +C +C Set the default tolerance, if needed. +C + IF( TOL.LE.ZERO ) THEN + TOLL = SQRT( DLAMCH( 'Epsilon' ) ) + ELSE + TOLL = TOL + END IF +C +C Workspace usage. +C + N2 = 2*N + I1 = 1 + N*N + I2 = I1 + N*N + I3 = I2 + NP*NP + I4 = I3 + M*M + I5 = I4 + NP*NP + I6 = I5 + M*M + I7 = I6 + M*N + I8 = I7 + M*N + I9 = I8 + N*N + I10 = I9 + N*N + I11 = I10 + N2 + I12 = I11 + N2 + I13 = I12 + N2 + I14 = I13 + N2*N2 + I15 = I14 + N2*N2 +C + IWRK = I15 + N2*N2 + LWAMAX = 0 +C +C Compute R1 = Ip + D*D' . +C + CALL DLASET( 'U', NP, NP, ZERO, ONE, DWORK( I2 ), NP ) + CALL DSYRK( 'U', 'N', NP, M, ONE, D, LDD, ONE, DWORK( I2 ), NP ) + CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I4 ), NP ) +C +C Factorize R1 = R'*R . +C + CALL DPOTRF( 'U', NP, DWORK( I4 ), NP, INFO2 ) +C -1 +C Compute C'*R in BK . +C + CALL MA02AD( 'F', NP, N, C, LDC, BK, LDBK ) + CALL DTRSM( 'R', 'U', 'N', 'N', N, NP, ONE, DWORK( I4 ), NP, BK, + $ LDBK ) +C +C Compute R2 = Im + D'*D . +C + CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I3 ), M ) + CALL DSYRK( 'U', 'T', M, NP, ONE, D, LDD, ONE, DWORK( I3 ), M ) + CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I5 ), M ) +C +C Factorize R2 = U'*U . +C + CALL DPOTRF( 'U', M, DWORK( I5 ), M, INFO2 ) +C -1 +C Compute (U )'*B' . +C + CALL MA02AD( 'F', N, M, B, LDB, DWORK( I6 ), M ) + CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I6 ), M, + $ INFO2 ) +C +C Compute D'*C . +C + CALL DGEMM( 'T', 'N', M, N, NP, ONE, D, LDD, C, LDC, ZERO, + $ DWORK( I7 ), M ) +C -1 +C Compute (U )'*D'*C . +C + CALL DTRTRS( 'U', 'T', 'N', M, N, DWORK( I5 ), M, DWORK( I7 ), M, + $ INFO2 ) +C -1 +C Compute Ar = A - B*R2 D'*C . +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I8 ), N ) + CALL DGEMM( 'T', 'N', N, N, M, -ONE, DWORK( I6 ), M, DWORK( I7 ), + $ M, ONE, DWORK( I8 ), N ) +C -1 +C Compute Cr = C'*R1 *C . +C + CALL DSYRK( 'U', 'N', N, NP, ONE, BK, LDBK, ZERO, DWORK( I9 ), N ) +C -1 +C Compute Dr = B*R2 B' in AK . +C + CALL DSYRK( 'U', 'T', N, M, ONE, DWORK( I6 ), M, ZERO, AK, LDAK ) +C -1 +C Solution of the Riccati equation Ar'*P*(In + Dr*P) Ar - P + +C Cr = 0 . + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), + $ N, AK, LDAK, DWORK( I9 ), N, DWORK, M, DWORK, N, + $ RCOND( 1 ), DWORK, N, DWORK( I10 ), DWORK( I11 ), + $ DWORK( I12 ), DWORK( I13 ), N2, DWORK( I14 ), N2, + $ DWORK( I15 ), N2, -ONE, IWORK, DWORK( IWRK ), + $ LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C +C Transpose Ar . +C + DO 10 J = 1, N - 1 + CALL DSWAP( J, DWORK( I8+J ), N, DWORK( I8+J*N ), 1 ) + 10 CONTINUE +C -1 +C Solution of the Riccati equation Ar*Q*(In + Cr*Q) *Ar' - Q + +C Dr = 0 . + CALL SB02OD( 'D', 'G', 'N', 'U', 'Z', 'S', N, M, NP, DWORK( I8 ), + $ N, DWORK( I9 ), N, AK, LDAK, DWORK, M, DWORK, N, + $ RCOND( 2 ), DWORK( I1 ), N, DWORK( I10 ), + $ DWORK( I11 ), DWORK( I12 ), DWORK( I13 ), N2, + $ DWORK( I14 ), N2, DWORK( I15 ), N2, -ONE, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 2 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C +C Compute gamma. +C + CALL DGEMM( 'N', 'N', N, N, N, ONE, DWORK( I1 ), N, DWORK, N, + $ ZERO, DWORK( I8 ), N ) + CALL DGEES( 'N', 'N', SELECT, N, DWORK( I8 ), N, SDIM, + $ DWORK( I10 ), DWORK( I11 ), DWORK( IWRK ), N, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) + GAMMA = ZERO +C + DO 20 I = 0, N - 1 + GAMMA = MAX( GAMMA, DWORK( I10+I ) ) + 20 CONTINUE +C + GAMMA = FACTOR*SQRT( ONE + GAMMA ) +C +C Workspace usage. +C + I5 = I4 + NP*NP + I6 = I5 + M*M + I7 = I6 + NP*NP + I8 = I7 + NP*NP + I9 = I8 + NP*NP + I10 = I9 + NP + I11 = I10 + NP*NP + I12 = I11 + M*M + I13 = I12 + M +C + IWRK = I13 + M*M +C +C Compute the eigenvalues and eigenvectors of R1 . +C + CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) + CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C -1/2 +C Compute R1 . +C + DO 40 J = 1, NP + DO 30 I = 1, NP + DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / + $ SQRT( DWORK( I9+I-1 ) ) + 30 CONTINUE + 40 CONTINUE +C + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, + $ DWORK( I10 ), NP, ZERO, DWORK( I4 ), NP ) +C +C Compute the eigenvalues and eigenvectors of R2 . +C + CALL DLACPY( 'U', M, M, DWORK( I3 ), M, DWORK( I11 ), M ) + CALL DSYEV( 'V', 'U', M, DWORK( I11 ), M, DWORK( I12 ), + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C -1/2 +C Compute R2 . +C + DO 60 J = 1, M + DO 50 I = 1, M + DWORK( I13-1+I+(J-1)*M ) = DWORK( I11-1+J+(I-1)*M ) / + $ SQRT( DWORK( I12+I-1 ) ) + 50 CONTINUE + 60 CONTINUE +C + CALL DGEMM( 'N', 'N', M, M, M, ONE, DWORK( I11 ), M, DWORK( I13 ), + $ M, ZERO, DWORK( I5 ), M ) +C +C Compute R1 + C*Q*C' . +C + CALL DGEMM( 'N', 'T', N, NP, N, ONE, DWORK( I1 ), N, C, LDC, + $ ZERO, BK, LDBK ) + CALL MB01RX( 'L', 'U', 'N', NP, N, ONE, ONE, DWORK( I2 ), NP, + $ C, LDC, BK, LDBK, INFO2 ) + CALL DLACPY( 'U', NP, NP, DWORK( I2 ), NP, DWORK( I8 ), NP ) +C +C Compute the eigenvalues and eigenvectors of R1 + C*Q*C' . +C + CALL DSYEV( 'V', 'U', NP, DWORK( I8 ), NP, DWORK( I9 ), + $ DWORK( IWRK ), LDWORK-IWRK+1, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C -1 +C Compute ( R1 + C*Q*C' ) . +C + DO 80 J = 1, NP + DO 70 I = 1, NP + DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP ) / + $ DWORK( I9+I-1 ) + 70 CONTINUE + 80 CONTINUE +C + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, + $ DWORK( I10 ), NP, ZERO, DWORK( I6 ), NP ) +C -1 +C Compute Z2 . +C + DO 100 J = 1, NP + DO 90 I = 1, NP + DWORK( I10-1+I+(J-1)*NP ) = DWORK( I8-1+J+(I-1)*NP )* + $ SQRT( DWORK( I9+I-1 ) ) + 90 CONTINUE + 100 CONTINUE +C + CALL DGEMM( 'N', 'N', NP, NP, NP, ONE, DWORK( I8 ), NP, + $ DWORK( I10 ), NP, ZERO, DWORK( I7 ), NP ) +C +C Workspace usage. +C + I9 = I8 + N*NP + I10 = I9 + N*NP + I11 = I10 + NP*M + I12 = I11 + ( NP + M )*( NP + M ) + I13 = I12 + N*( NP + M ) + I14 = I13 + N*( NP + M ) + I15 = I14 + N*N + I16 = I15 + N*N + I17 = I16 + ( NP + M )*N + I18 = I17 + ( NP + M )*( NP + M ) + I19 = I18 + ( NP + M )*N + I20 = I19 + M*N + I21 = I20 + M*NP + I22 = I21 + NP*N + I23 = I22 + N*N + I24 = I23 + N*NP + I25 = I24 + NP*NP + I26 = I25 + M*M +C + IWRK = I26 + N*M +C +C Compute A*Q*C' + B*D' . +C + CALL DGEMM( 'N', 'T', N, NP, M, ONE, B, LDB, D, LDD, ZERO, + $ DWORK( I8 ), N ) + CALL DGEMM( 'N', 'N', N, NP, N, ONE, A, LDA, BK, LDBK, + $ ONE, DWORK( I8 ), N ) +C -1 +C Compute H = -( A*Q*C'+B*D' )*( R1 + C*Q*C' ) . +C + CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I8 ), N, + $ DWORK( I6 ), NP, ZERO, DWORK( I9 ), N ) +C -1/2 +C Compute R1 D . +C + CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I4 ), NP, D, LDD, + $ ZERO, DWORK( I10 ), NP ) +C +C Compute Rx . +C + DO 110 J = 1, NP + CALL DCOPY( J, DWORK( I2+(J-1)*NP ), 1, + $ DWORK( I11+(J-1)*(NP+M) ), 1 ) + DWORK( I11-1+J+(J-1)*(NP+M) ) = DWORK( I2-1+J+(J-1)*NP ) - + $ GAMMA*GAMMA + 110 CONTINUE +C + CALL DGEMM( 'N', 'N', NP, M, NP, ONE, DWORK( I7 ), NP, + $ DWORK( I10 ), NP, ZERO, DWORK( I11+(NP+M)*NP ), + $ NP+M ) + CALL DLASET( 'U', M, M, ZERO, ONE, DWORK( I11+(NP+M)*NP+NP ), + $ NP+M ) +C +C Compute Bx . +C + CALL DGEMM( 'N', 'N', N, NP, NP, -ONE, DWORK( I9 ), N, + $ DWORK( I7 ), NP, ZERO, DWORK( I12 ), N ) + CALL DGEMM( 'N', 'N', N, M, M, ONE, B, LDB, DWORK( I5 ), M, + $ ZERO, DWORK( I12+N*NP ), N ) +C +C Compute Sx . +C + CALL DGEMM( 'T', 'N', N, NP, NP, ONE, C, LDC, DWORK( I7 ), NP, + $ ZERO, DWORK( I13 ), N ) + CALL DGEMM( 'T', 'N', N, M, NP, ONE, C, LDC, DWORK( I10 ), NP, + $ ZERO, DWORK( I13+N*NP ), N ) +C +C Compute (gamma^2 - 1)*In - P*Q . +C + CALL DLASET( 'F', N, N, ZERO, GAMMA*GAMMA-ONE, DWORK( I14 ), N ) + CALL DGEMM( 'N', 'N', N, N, N, -ONE, DWORK, N, DWORK( I1 ), N, + $ ONE, DWORK( I14 ), N ) +C -1 +C Compute X = ((gamma^2 - 1)*In - P*Q) *gamma^2*P . +C + CALL DLACPY( 'F', N, N, DWORK, N, DWORK( I15 ), N ) + CALL DLASCL( 'G', 0, 0, ONE, GAMMA*GAMMA, N, N, DWORK( I15 ), N, + $ INFO ) + ANORM = DLANGE( '1', N, N, DWORK( I14 ), N, DWORK( IWRK ) ) + CALL DGETRF( N, N, DWORK( I14 ), N, IWORK, INFO2 ) + IF( INFO2.GT.0 ) THEN + INFO = 4 + RETURN + END IF + CALL DGECON( '1', N, DWORK( I14 ), N, ANORM, RCOND( 3 ), + $ DWORK( IWRK ), IWORK( N+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 3 ).LT.TOLL ) THEN + INFO = 4 + RETURN + END IF + CALL DGETRS( 'N', N, N, DWORK( I14 ), N, IWORK, DWORK( I15 ), + $ N, INFO2 ) +C +C Compute Bx'*X . +C + CALL DGEMM( 'T', 'N', NP+M, N, N, ONE, DWORK( I12 ), N, + $ DWORK( I15 ), N, ZERO, DWORK( I16 ), NP+M ) +C +C Compute Rx + Bx'*X*Bx . +C + CALL DLACPY( 'U', NP+M, NP+M, DWORK( I11 ), NP+M, DWORK( I17 ), + $ NP+M ) + CALL MB01RX( 'L', 'U', 'N', NP+M, N, ONE, ONE, DWORK( I17 ), NP+M, + $ DWORK( I16 ), NP+M, DWORK( I12 ), N, INFO2 ) +C +C Compute -( Sx' + Bx'*X*A ) . +C + CALL MA02AD( 'F', N, NP+M, DWORK( I13 ), N, DWORK( I18 ), NP+M ) + CALL DGEMM( 'N', 'N', NP+M, N, N, -ONE, DWORK( I16 ), NP+M, + $ A, LDA, -ONE, DWORK( I18 ), NP+M ) +C +C Factorize Rx + Bx'*X*Bx . +C + ANORM = DLANSY( '1', 'U', NP+M, DWORK( I17 ), NP+M, + $ DWORK( IWRK ) ) + CALL DSYTRF( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, + $ DWORK( IWRK ), LDWORK-IWRK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + CALL DSYCON( 'U', NP+M, DWORK( I17 ), NP+M, IWORK, ANORM, + $ RCOND( 4 ), DWORK( IWRK ), IWORK( NP+M+1), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 4 ).LT.TOLL ) THEN + INFO = 5 + RETURN + END IF +C -1 +C Compute F = -( Rx + Bx'*X*Bx ) ( Sx' + Bx'*X*A ) . +C + CALL DSYTRS( 'U', NP+M, N, DWORK( I17 ), NP+M, IWORK, + $ DWORK( I18 ), NP+M, INFO2 ) +C +C Compute B'*X . +C + CALL DGEMM( 'T', 'N', M, N, N, ONE, B, LDB, DWORK( I15 ), N, + $ ZERO, DWORK( I19 ), M ) +C +C Compute -( D' - B'*X*H ) . +C + DO 130 J = 1, NP + DO 120 I = 1, M + DWORK( I20-1+I+(J-1)*M ) = -D( J, I ) + 120 CONTINUE + 130 CONTINUE +C + CALL DGEMM( 'N', 'N', M, NP, N, ONE, DWORK( I19 ), M, + $ DWORK( I9 ), N, ONE, DWORK( I20 ), M ) +C -1 +C Compute C + Z2 *F1 . +C + CALL DLACPY( 'F', NP, N, C, LDC, DWORK( I21 ), NP ) + CALL DGEMM( 'N', 'N', NP, N, NP, ONE, DWORK( I7 ), NP, + $ DWORK( I18 ), NP+M, ONE, DWORK( I21 ), NP ) +C +C Compute R2 + B'*X*B . +C + CALL MB01RX( 'L', 'U', 'N', M, N, ONE, ONE, DWORK( I3 ), M, + $ DWORK( I19 ), M, B, LDB, INFO2 ) +C +C Factorize R2 + B'*X*B . +C + CALL DPOTRF( 'U', M, DWORK( I3 ), M, INFO2 ) +C ^ -1 +C Compute Dk = -( R2 + B'*X*B ) (D' - B'*X*H) . +C + CALL DLACPY( 'F', M, NP, DWORK( I20 ), M, DK, LDDK ) + CALL DPOTRS( 'U', M, NP, DWORK( I3 ), M, DK, LDDK, INFO2 ) +C ^ ^ +C Compute Bk = -H + B*Dk . +C + CALL DLACPY( 'F', N, NP, DWORK( I9 ), N, DWORK( I23 ), N ) + CALL DGEMM( 'N', 'N', N, NP, M, ONE, B, LDB, DK, LDDK, + $ -ONE, DWORK( I23 ), N ) +C -1/2 +C Compute R2 *F2 . +C + CALL DGEMM( 'N', 'N', M, N, M, ONE, DWORK( I5 ), M, + $ DWORK( I18+NP ), NP+M, ZERO, CK, LDCK ) +C ^ -1/2 ^ -1 +C Compute Ck = R2 *F2 - Dk*( C + Z2 *F1 ) . +C + CALL DGEMM( 'N', 'N', M, N, NP, -ONE, DK, LDDK, + $ DWORK( I21 ), NP, ONE, CK, LDCK ) +C ^ ^ +C Compute Ak = A + H*C + B*Ck . +C + CALL DLACPY( 'F', N, N, A, LDA, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I9 ), N, C, LDC, + $ ONE, AK, LDAK ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, B, LDB, CK, LDCK, + $ ONE, AK, LDAK ) +C ^ +C Compute Ip + D*Dk . +C + CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK( I24 ), NP ) + CALL DGEMM( 'N', 'N', NP, NP, M, ONE, D, LDD, DK, LDDK, + $ ONE, DWORK( I24 ), NP ) +C ^ +C Compute Im + Dk*D . +C + CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I25 ), M ) + CALL DGEMM( 'N', 'N', M, M, NP, ONE, DK, LDDK, D, LDD, + $ ONE, DWORK( I25 ), M ) +C ^ ^ ^ ^ -1 +C Compute Ck = M*Ck, M = (Im + Dk*D) . +C + ANORM = DLANGE( '1', M, M, DWORK( I25 ), M, DWORK( IWRK ) ) + CALL DGETRF( M, M, DWORK( I25 ), M, IWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 7 + RETURN + END IF + CALL DGECON( '1', M, DWORK( I25 ), M, ANORM, RCOND( 6 ), + $ DWORK( IWRK ), IWORK( M+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 6 ).LT.TOLL ) THEN + INFO = 7 + RETURN + END IF + CALL DGETRS( 'N', M, N, DWORK( I25 ), M, IWORK, CK, LDCK, INFO2 ) +C ^ ^ +C Compute Dk = M*Dk . +C + CALL DGETRS( 'N', M, NP, DWORK( I25 ), M, IWORK, DK, LDDK, INFO2 ) +C ^ +C Compute Bk*D . +C + CALL DGEMM( 'N', 'N', N, M, NP, ONE, DWORK( I23 ), N, D, LDD, + $ ZERO, DWORK( I26 ), N ) +C ^ ^ +C Compute Ak = Ak - Bk*D*Ck. +C + CALL DGEMM( 'N', 'N', N, N, M, -ONE, DWORK( I26 ), N, CK, LDCK, + $ ONE, AK, LDAK ) +C ^ ^ -1 +C Compute Bk = Bk*(Ip + D*Dk) . +C + ANORM = DLANGE( '1', NP, NP, DWORK( I24 ), NP, DWORK( IWRK ) ) + CALL DLACPY( 'Full', N, NP, DWORK( I23 ), N, BK, LDBK ) + CALL MB02VD( 'N', N, NP, DWORK( I24 ), NP, IWORK, BK, LDBK, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 6 + RETURN + END IF + CALL DGECON( '1', NP, DWORK( I24 ), NP, ANORM, RCOND( 5 ), + $ DWORK( IWRK ), IWORK( NP+1 ), INFO2 ) +C +C Return if the matrix is singular to working precision. +C + IF( RCOND( 5 ).LT.TOLL ) THEN + INFO = 6 + RETURN + END IF +C +C Workspace usage. +C + I2 = 1 + NP*NP + I3 = I2 + N*NP + I4 = I3 + M*M + I5 = I4 + N*M + I6 = I5 + NP*N + I7 = I6 + M*N + I8 = I7 + N2*N2 + I9 = I8 + N2 +C + IWRK = I9 + N2 +C +C Compute Ip - D*Dk . +C + CALL DLASET( 'Full', NP, NP, ZERO, ONE, DWORK, NP ) + CALL DGEMM( 'N', 'N', NP, NP, M, -ONE, D, LDD, DK, LDDK, ONE, + $ DWORK, NP ) +C -1 +C Compute Bk*(Ip-D*Dk) . +C + CALL DLACPY( 'Full', N, NP, BK, LDBK, DWORK( I2 ), N ) + CALL MB02VD( 'N', N, NP, DWORK, NP, IWORK, DWORK( I2 ), N, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 8 + RETURN + END IF +C +C Compute Im - Dk*D . +C + CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK( I3 ), M ) + CALL DGEMM( 'N', 'N', M, M, NP, -ONE, DK, LDDK, D, LDD, ONE, + $ DWORK( I3 ), M ) +C -1 +C Compute B*(Im-Dk*D) . +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK( I4 ), N ) + CALL MB02VD( 'N', N, M, DWORK( I3 ), M, IWORK, DWORK( I4 ), N, + $ INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 9 + RETURN + END IF +C +C Compute D*Ck . +C + CALL DGEMM( 'N', 'N', NP, N, M, ONE, D, LDD, CK, LDCK, ZERO, + $ DWORK( I5 ), NP ) +C +C Compute Dk*C . +C + CALL DGEMM( 'N', 'N', M, N, NP, ONE, DK, LDDK, C, LDC, ZERO, + $ DWORK( I6 ), M ) +C +C Compute the closed-loop state matrix. +C + CALL DLACPY( 'F', N, N, A, LDA, DWORK( I7 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, + $ DWORK( I6 ), M, ONE, DWORK( I7 ), N2 ) + CALL DGEMM( 'N', 'N', N, N, M, ONE, DWORK( I4 ), N, CK, LDCK, + $ ZERO, DWORK( I7+N2*N ), N2 ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, C, LDC, + $ ZERO, DWORK( I7+N ), N2 ) + CALL DLACPY( 'F', N, N, AK, LDAK, DWORK( I7+N2*N+N ), N2 ) + CALL DGEMM( 'N', 'N', N, N, NP, ONE, DWORK( I2 ), N, + $ DWORK( I5 ), NP, ONE, DWORK( I7+N2*N+N ), N2 ) +C +C Compute the closed-loop poles. +C + CALL DGEES( 'N', 'N', SELECT, N2, DWORK( I7 ), N2, SDIM, + $ DWORK( I8 ), DWORK( I9 ), DWORK( IWRK ), N, + $ DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 ) + IF( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + LWAMAX = MAX( LWAMAX, INT( DWORK( IWRK ) ) + IWRK - 1 ) +C +C Check the stability of the closed-loop system. +C + NS = 0 +C + DO 140 I = 0, N2 - 1 + IF( DLAPY2( DWORK( I8+I ), DWORK( I9+I ) ).GT.ONE ) + $ NS = NS + 1 + 140 CONTINUE +C + IF( NS.GT.0 ) THEN + INFO = 10 + RETURN + END IF +C + DWORK( 1 ) = DBLE( LWAMAX ) + RETURN +C *** Last line of SB10ZD *** + END diff --git a/mex/sources/libslicot/SB10ZP.f b/mex/sources/libslicot/SB10ZP.f new file mode 100644 index 000000000..efaa9ac14 --- /dev/null +++ b/mex/sources/libslicot/SB10ZP.f @@ -0,0 +1,339 @@ + SUBROUTINE SB10ZP( DISCFL, N, A, LDA, B, C, D, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To transform a SISO (single-input single-output) system [A,B;C,D] +C by mirroring its unstable poles and zeros in the boundary of the +C stability domain, thus preserving the frequency response of the +C system, but making it stable and minimum phase. Specifically, for +C a continuous-time system, the positive real parts of its poles +C and zeros are exchanged with their negatives. Discrete-time +C systems are first converted to continuous-time systems using a +C bilinear transformation, and finally converted back. +C +C ARGUMENTS +C +C Input/Output parameters +C +C DISCFL (input) INTEGER +C Indicates the type of the system, as follows: +C = 0: continuous-time system; +C = 1: discrete-time system. +C +C N (input/output) INTEGER +C On entry, the order of the original system. N >= 0. +C On exit, the order of the transformed, minimal system. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original system matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed matrix A, in an upper Hessenberg form. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the original system +C vector B. +C On exit, this array contains the transformed vector B. +C +C C (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the original system +C vector C. +C On exit, this array contains the transformed vector C. +C The first N-1 elements are zero (for the exit value of N). +C +C D (input/output) DOUBLE PRECISION array, dimension (1) +C On entry, this array must contain the original system +C scalar D. +C On exit, this array contains the transformed scalar D. +C +C Workspace +C +C IWORK INTEGER array, dimension max(2,N+1) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= max(N*N + 5*N, 6*N + 1 + min(1,N)). +C For optimum performance LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the discrete --> continuous transformation cannot +C be made; +C = 2: if the system poles cannot be found; +C = 3: if the inverse system cannot be found, i.e., D is +C (close to) zero; +C = 4: if the system zeros cannot be found; +C = 5: if the state-space representation of the new +C transfer function T(s) cannot be found; +C = 6: if the continuous --> discrete transformation cannot +C be made. +C +C METHOD +C +C First, if the system is discrete-time, it is transformed to +C continuous-time using alpha = beta = 1 in the bilinear +C transformation implemented in the SLICOT routine AB04MD. +C Then the eigenvalues of A, i.e., the system poles, are found. +C Then, the inverse of the original system is found and its poles, +C i.e., the system zeros, are evaluated. +C The obtained system poles Pi and zeros Zi are checked and if a +C positive real part is detected, it is exchanged by -Pi or -Zi. +C Then the polynomial coefficients of the transfer function +C T(s) = Q(s)/P(s) are found. +C The state-space representation of T(s) is then obtained. +C The system matrices B, C, D are scaled so that the transformed +C system has the same system gain as the original system. +C If the original system is discrete-time, then the result (which is +C continuous-time) is converted back to discrete-time. +C +C CONTRIBUTORS +C +C Asparuh Markovski, Technical University of Sofia, July 2003. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2003. +C +C KEYWORDS +C +C Bilinear transformation, stability, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +C .. +C .. Scalar Arguments .. + INTEGER DISCFL, INFO, LDA, LDWORK, N +C .. +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( * ), C( * ), D( * ), DWORK( * ) +C .. +C .. Local Scalars .. + INTEGER I, IDW1, IDW2, IDW3, IMP, IMZ, INFO2, IWA, IWP, + $ IWPS, IWQ, IWQS, LDW1, MAXWRK, REP, REZ + DOUBLE PRECISION RCOND, SCALB, SCALC, SCALD +C .. +C .. Local Arrays .. + INTEGER INDEX(1) +C .. +C .. External Subroutines .. + EXTERNAL AB04MD, AB07ND, DCOPY, DGEEV, DLACPY, DSCAL, + $ MC01PD, TD04AD, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SIGN, SQRT +C +C Test input parameters and workspace. +C + INFO = 0 + IF ( DISCFL.NE.0 .AND. DISCFL.NE.1 ) THEN + INFO = -1 + ELSE IF ( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF ( LDWORK.LT.MAX( N*N + 5*N, 6*N + 1 + MIN( 1, N ) ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB10ZP', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Workspace usage 1. +C + REP = 1 + IMP = REP + N + REZ = IMP + N + IMZ = REZ + N + IWA = REZ + IDW1 = IWA + N*N + LDW1 = LDWORK - IDW1 + 1 +C +C 1. Discrete --> continuous transformation if needed. +C + IF ( DISCFL.EQ.1 ) THEN +C +C Workspace: need max(1,N); +C prefer larger. +C + CALL AB04MD( 'D', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, + $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 1 + RETURN + END IF + MAXWRK = INT( DWORK(1) ) + ELSE + MAXWRK = 0 + END IF +C +C 2. Determine the factors for restoring system gain. +C + SCALD = D(1) + SCALC = SQRT( ABS( SCALD ) ) + SCALB = SIGN( SCALC, SCALD ) +C +C 3. Find the system poles, i.e., the eigenvalues of A. +C Workspace: need N*N + 2*N + 3*N; +C prefer larger. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IWA), N ) +C + CALL DGEEV( 'N', 'N', N, DWORK(IWA), N, DWORK(REP), DWORK(IMP), + $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, + $ INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 2 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) +C +C 4. Compute the inverse system [Ai, Bi; Ci, Di]. +C Workspace: need N*N + 2*N + 4; +C prefer larger. +C + CALL AB07ND( N, 1, A, LDA, B, LDA, C, 1, D, 1, RCOND, IWORK, + $ DWORK(IDW1), LDW1, INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 3 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) +C +C 5. Find the system zeros, i.e., the eigenvalues of Ai. +C Workspace: need 4*N + 3*N; +C prefer larger. +C + IDW1 = IMZ + N + LDW1 = LDWORK - IDW1 + 1 +C + CALL DGEEV( 'N', 'N', N, A, LDA, DWORK(REZ), DWORK(IMZ), + $ DWORK(IDW1), 1, DWORK(IDW1), 1, DWORK(IDW1), LDW1, + $ INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 4 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(IDW1) + IDW1 - 1 ) ) +C +C 6. Exchange the zeros and the poles with positive real parts with +C their negatives. +C + DO 10 I = 0, N - 1 + IF ( DWORK(REP+I).GT.ZERO ) + $ DWORK(REP+I) = -DWORK(REP+I) + IF ( DWORK(REZ+I).GT.ZERO ) + $ DWORK(REZ+I) = -DWORK(REZ+I) + 10 CONTINUE +C +C Workspace usage 2. +C + IWP = IDW1 + IDW2 = IWP + N + 1 + IWPS = 1 +C +C 7. Construct the nominator and the denominator +C of the system transfer function T( s ) = Q( s )/P( s ). +C 8. Rearrange the coefficients in Q(s) and P(s) because +C MC01PD subroutine produces them in increasing powers of s. +C Workspace: need 6*N + 2. +C + CALL MC01PD( N, DWORK(REP), DWORK(IMP), DWORK(IWP), DWORK(IDW2), + $ INFO2 ) + CALL DCOPY( N+1, DWORK(IWP), -1, DWORK(IWPS), 1 ) +C +C Workspace usage 3. +C + IWQ = IDW1 + IWQS = IWPS + N + 1 + IDW3 = IWQS + N + 1 +C + CALL MC01PD( N, DWORK(REZ), DWORK(IMZ), DWORK(IWQ), DWORK(IDW2), + $ INFO2 ) + CALL DCOPY( N+1, DWORK(IWQ), -1, DWORK(IWQS), 1 ) +C +C 9. Make the conversion T(s) --> [A, B; C, D]. +C Workspace: need 2*N + 2 + N + max(N,3); +C prefer larger. +C + INDEX(1) = N + CALL TD04AD( 'R', 1, 1, INDEX, DWORK(IWPS), 1, DWORK(IWQS), 1, 1, + $ N, A, LDA, B, LDA, C, 1, D, 1, -ONE, IWORK, + $ DWORK(IDW3), LDWORK-IDW3+1, INFO2 ) + IF ( INFO2.NE.0 ) THEN + INFO = 5 + RETURN + END IF + MAXWRK = MAX( MAXWRK, INT( DWORK(IDW3) + IDW3 - 1 ) ) +C +C 10. Scale the transformed system to the previous gain. +C + IF ( N.GT.0 ) THEN + CALL DSCAL( N, SCALB, B, 1 ) + C(N) = SCALC*C(N) + END IF +C + D(1) = SCALD +C +C 11. Continuous --> discrete transformation if needed. +C + IF ( DISCFL.EQ.1 ) THEN + CALL AB04MD( 'C', N, 1, 1, ONE, ONE, A, LDA, B, LDA, C, 1, + $ D, 1, IWORK, DWORK, LDWORK, INFO2 ) + + IF ( INFO2.NE.0 ) THEN + INFO = 6 + RETURN + END IF + END IF +C + DWORK(1) = MAXWRK + RETURN +C +C *** Last line of SB10ZP *** + END diff --git a/mex/sources/libslicot/SB16AD.f b/mex/sources/libslicot/SB16AD.f new file mode 100644 index 000000000..565147c9f --- /dev/null +++ b/mex/sources/libslicot/SB16AD.f @@ -0,0 +1,719 @@ + SUBROUTINE SB16AD( DICO, JOBC, JOBO, JOBMR, WEIGHT, EQUIL, ORDSEL, + $ N, M, P, NC, NCR, ALPHA, A, LDA, B, LDB, + $ C, LDC, D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, + $ DC, LDDC, NCS, HSVC, TOL1, TOL2, IWORK, DWORK, + $ LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute a reduced order controller (Acr,Bcr,Ccr,Dcr) for an +C original state-space controller representation (Ac,Bc,Cc,Dc) by +C using the frequency-weighted square-root or balancing-free +C square-root Balance & Truncate (B&T) or Singular Perturbation +C Approximation (SPA) model reduction methods. The algorithm tries +C to minimize the norm of the frequency-weighted error +C +C ||V*(K-Kr)*W|| +C +C where K and Kr are the transfer-function matrices of the original +C and reduced order controllers, respectively. V and W are special +C frequency-weighting transfer-function matrices constructed +C to enforce closed-loop stability and/or closed-loop performance. +C If G is the transfer-function matrix of the open-loop system, then +C the following weightings V and W can be used: +C -1 +C (a) V = (I-G*K) *G, W = I - to enforce closed-loop stability; +C -1 +C (b) V = I, W = (I-G*K) *G - to enforce closed-loop stability; +C -1 -1 +C (c) V = (I-G*K) *G, W = (I-G*K) - to enforce closed-loop +C stability and performance. +C +C G has the state space representation (A,B,C,D). +C If K is unstable, only the ALPHA-stable part of K is reduced. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the original controller as follows: +C = 'C': continuous-time controller; +C = 'D': discrete-time controller. +C +C JOBC CHARACTER*1 +C Specifies the choice of frequency-weighted controllability +C Grammian as follows: +C = 'S': choice corresponding to standard Enns' method [1]; +C = 'E': choice corresponding to the stability enhanced +C modified Enns' method of [2]. +C +C JOBO CHARACTER*1 +C Specifies the choice of frequency-weighted observability +C Grammian as follows: +C = 'S': choice corresponding to standard Enns' method [1]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [2]. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root B&T method; +C = 'F': use the balancing-free square-root B&T method; +C = 'S': use the square-root SPA method; +C = 'P': use the balancing-free square-root SPA method. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency-weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'O': stability enforcing left (output) weighting +C -1 +C V = (I-G*K) *G is used (W = I); +C = 'I': stability enforcing right (input) weighting +C -1 +C W = (I-G*K) *G is used (V = I); +C = 'P': stability and performance enforcing weightings +C -1 -1 +C V = (I-G*K) *G , W = (I-G*K) are used. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplets (A,B,C) and (Ac,Bc,Cc) as +C follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting order NCR is fixed; +C = 'A': the resulting order NCR is automatically +C determined on basis of the given tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the open-loop system state-space +C representation, i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NC (input) INTEGER +C The order of the controller state-space representation, +C i.e., the order of the matrix AC. NC >= 0. +C +C NCR (input/output) INTEGER +C On entry with ORDSEL = 'F', NCR is the desired order of +C the resulting reduced order controller. 0 <= NCR <= NC. +C On exit, if INFO = 0, NCR is the order of the resulting +C reduced order controller. For a controller with NCU +C ALPHA-unstable eigenvalues and NCS ALPHA-stable +C eigenvalues (NCU+NCS = NC), NCR is set as follows: +C if ORDSEL = 'F', NCR is equal to +C NCU+MIN(MAX(0,NCR-NCU),NCMIN), where NCR is the desired +C order on entry, NCMIN is the number of frequency-weighted +C Hankel singular values greater than NCS*EPS*S1, EPS is the +C machine precision (see LAPACK Library Routine DLAMCH) and +C S1 is the largest Hankel singular value (computed in +C HSVC(1)); NCR can be further reduced to ensure +C HSVC(NCR-NCU) > HSVC(NCR+1-NCU); +C if ORDSEL = 'A', NCR is the sum of NCU and the number of +C Hankel singular values greater than MAX(TOL1,NCS*EPS*S1). +C +C ALPHA (input) DOUBLE PRECISION +C Specifies the ALPHA-stability boundary for the eigenvalues +C of the state dynamics matrix AC. For a continuous-time +C controller (DICO = 'C'), ALPHA <= 0 is the boundary value +C for the real parts of eigenvalues; for a discrete-time +C controller (DICO = 'D'), 0 <= ALPHA <= 1 represents the +C boundary value for the moduli of eigenvalues. +C The ALPHA-stability domain does not include the boundary. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A of the open-loop +C system. +C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-N +C part of this array contains the scaled state dynamics +C matrix of the open-loop system. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix B of the open-loop system. +C On exit, if INFO = 0 and EQUIL = 'S', the leading N-by-M +C part of this array contains the scaled input/state matrix +C of the open-loop system. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C of the open-loop system. +C On exit, if INFO = 0 and EQUIL = 'S', the leading P-by-N +C part of this array contains the scaled state/output matrix +C of the open-loop system. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C input/output matrix D of the open-loop system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AC (input/output) DOUBLE PRECISION array, dimension (LDAC,NC) +C On entry, the leading NC-by-NC part of this array must +C contain the state dynamics matrix Ac of the original +C controller. +C On exit, if INFO = 0, the leading NCR-by-NCR part of this +C array contains the state dynamics matrix Acr of the +C reduced controller. The resulting Ac has a +C block-diagonal form with two blocks. +C For a system with NCU ALPHA-unstable eigenvalues and +C NCS ALPHA-stable eigenvalues (NCU+NCS = NC), the leading +C NCU-by-NCU block contains the unreduced part of Ac +C corresponding to the ALPHA-unstable eigenvalues. +C The trailing (NCR+NCS-NC)-by-(NCR+NCS-NC) block contains +C the reduced part of Ac corresponding to ALPHA-stable +C eigenvalues. +C +C LDAC INTEGER +C The leading dimension of array AC. LDAC >= MAX(1,NC). +C +C BC (input/output) DOUBLE PRECISION array, dimension (LDBC,P) +C On entry, the leading NC-by-P part of this array must +C contain the input/state matrix Bc of the original +C controller. +C On exit, if INFO = 0, the leading NCR-by-P part of this +C array contains the input/state matrix Bcr of the reduced +C controller. +C +C LDBC INTEGER +C The leading dimension of array BC. LDBC >= MAX(1,NC). +C +C CC (input/output) DOUBLE PRECISION array, dimension (LDCC,NC) +C On entry, the leading M-by-NC part of this array must +C contain the state/output matrix Cc of the original +C controller. +C On exit, if INFO = 0, the leading M-by-NCR part of this +C array contains the state/output matrix Ccr of the reduced +C controller. +C +C LDCC INTEGER +C The leading dimension of array CC. LDCC >= MAX(1,M). +C +C DC (input/output) DOUBLE PRECISION array, dimension (LDDC,P) +C On entry, the leading M-by-P part of this array must +C contain the input/output matrix Dc of the original +C controller. +C On exit, if INFO = 0, the leading M-by-P part of this +C array contains the input/output matrix Dcr of the reduced +C controller. +C +C LDDC INTEGER +C The leading dimension of array DC. LDDC >= MAX(1,M). +C +C NCS (output) INTEGER +C The dimension of the ALPHA-stable part of the controller. +C +C HSVC (output) DOUBLE PRECISION array, dimension (NC) +C If INFO = 0, the leading NCS elements of this array +C contain the frequency-weighted Hankel singular values, +C ordered decreasingly, of the ALPHA-stable part of the +C controller. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of the reduced controller. +C For model reduction, the recommended value is +C TOL1 = c*S1, where c is a constant in the +C interval [0.00001,0.001], and S1 is the largest +C frequency-weighted Hankel singular value of the +C ALPHA-stable part of the original controller +C (computed in HSVC(1)). +C If TOL1 <= 0 on entry, the used default value is +C TOL1 = NCS*EPS*S1, where NCS is the number of +C ALPHA-stable eigenvalues of Ac and EPS is the machine +C precision (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the ALPHA-stable part of the given +C controller. The recommended value is TOL2 = NCS*EPS*S1. +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(1,LIWRK1,LIWRK2) +C LIWRK1 = 0, if JOBMR = 'B'; +C LIWRK1 = NC, if JOBMR = 'F'; +C LIWRK1 = 2*NC, if JOBMR = 'S' or 'P'; +C LIWRK2 = 0, if WEIGHT = 'N'; +C LIWRK2 = 2*(M+P), if WEIGHT = 'O', 'I', or 'P'. +C On exit, if INFO = 0, IWORK(1) contains NCMIN, the order +C of the computed minimal realization of the stable part of +C the controller. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*NC*NC + MAX( 1, LFREQ, LSQRED ), +C where +C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ +C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) +C if WEIGHT = 'I' or 'O' or 'P'; +C LFREQ = NC*(MAX(M,P)+5) if WEIGHT = 'N' and EQUIL = 'N'; +C LFREQ = MAX(N,NC*(MAX(M,P)+5)) if WEIGHT = 'N' and +C EQUIL = 'S'; +C LSQRED = MAX( 1, 2*NC*NC+5*NC ); +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NCR is greater +C than NSMIN, the sum of the order of the +C ALPHA-unstable part and the order of a minimal +C realization of the ALPHA-stable part of the given +C controller; in this case, the resulting NCR is set +C equal to NSMIN; +C = 2: with ORDSEL = 'F', the selected order NCR +C corresponds to repeated singular values for the +C ALPHA-stable part of the controller, which are +C neither all included nor all excluded from the +C reduced model; in this case, the resulting NCR is +C automatically decreased to exclude all repeated +C singular values; +C = 3: with ORDSEL = 'F', the selected order NCR is less +C than the order of the ALPHA-unstable part of the +C given controller. In this case NCR is set equal to +C the order of the ALPHA-unstable part. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the closed-loop system is not well-posed; +C its feedthrough matrix is (numerically) singular; +C = 2: the computation of the real Schur form of the +C closed-loop state matrix failed; +C = 3: the closed-loop state matrix is not stable; +C = 4: the solution of a symmetric eigenproblem failed; +C = 5: the computation of the ordered real Schur form of Ac +C failed; +C = 6: the separation of the ALPHA-stable/unstable +C diagonal blocks failed because of very close +C eigenvalues; +C = 7: the computation of Hankel singular values failed. +C +C METHOD +C +C Let K be the transfer-function matrix of the original linear +C controller +C +C d[xc(t)] = Ac*xc(t) + Bc*y(t) +C u(t) = Cc*xc(t) + Dc*y(t), (1) +C +C where d[xc(t)] is dxc(t)/dt for a continuous-time system and +C xc(t+1) for a discrete-time system. The subroutine SB16AD +C determines the matrices of a reduced order controller +C +C d[z(t)] = Acr*z(t) + Bcr*y(t) +C u(t) = Ccr*z(t) + Dcr*y(t), (2) +C +C such that the corresponding transfer-function matrix Kr minimizes +C the norm of the frequency-weighted error +C +C V*(K-Kr)*W, (3) +C +C where V and W are special stable transfer-function matrices +C chosen to enforce stability and/or performance of the closed-loop +C system [3] (see description of the parameter WEIGHT). +C +C The following procedure is used to reduce K in conjunction +C with the frequency-weighted balancing approach of [2] +C (see also [3]): +C +C 1) Decompose additively K, of order NC, as +C +C K = K1 + K2, +C +C such that K1 has only ALPHA-stable poles and K2, of order NCU, +C has only ALPHA-unstable poles. +C +C 2) Compute for K1 a B&T or SPA frequency-weighted approximation +C K1r of order NCR-NCU using the frequency-weighted balancing +C approach of [1] in conjunction with accuracy enhancing +C techniques specified by the parameter JOBMR. +C +C 3) Assemble the reduced model Kr as +C +C Kr = K1r + K2. +C +C For the reduction of the ALPHA-stable part, several accuracy +C enhancing techniques can be employed (see [2] for details). +C +C If JOBMR = 'B', the square-root B&T method of [1] is used. +C +C If JOBMR = 'F', the balancing-free square-root version of the +C B&T method [1] is used. +C +C If JOBMR = 'S', the square-root version of the SPA method [2,3] +C is used. +C +C If JOBMR = 'P', the balancing-free square-root version of the +C SPA method [2,3] is used. +C +C For each of these methods, two left and right truncation matrices +C are determined using the Cholesky factors of an input +C frequency-weighted controllability Grammian P and an output +C frequency-weighted observability Grammian Q. +C P and Q are determined as the leading NC-by-NC diagonal blocks +C of the controllability Grammian of K*W and of the +C observability Grammian of V*K. Special techniques developed in [2] +C are used to compute the Cholesky factors of P and Q directly +C (see also SLICOT Library routine SB16AY). +C The frequency-weighted Hankel singular values HSVC(1), ...., +C HSVC(NC) are computed as the square roots of the eigenvalues +C of the product P*Q. +C +C REFERENCES +C +C [1] Enns, D. +C Model reduction with balanced realizations: An error bound +C and a frequency weighted generalization. +C Proc. 23-th CDC, Las Vegas, pp. 127-132, 1984. +C +C [2] Varga, A. and Anderson, B.D.O. +C Square-root balancing-free methods for frequency-weighted +C balancing related model reduction. +C (report in preparation) +C +C [3] Anderson, B.D.O and Liu, Y. +C Controller reduction: concepts and approaches. +C IEEE Trans. Autom. Control, Vol. 34, pp. 802-812, 1989. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root +C techniques. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, Sept. 2000. +C D. Sima, University of Bucharest, Sept. 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Sept.2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Sep. 2001. +C +C KEYWORDS +C +C Controller reduction, frequency weighting, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION C100, ONE, ZERO + PARAMETER ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBC, JOBO, JOBMR, ORDSEL, WEIGHT + INTEGER INFO, IWARN, LDA, LDAC, LDB, LDBC, LDC, LDCC, + $ LDD, LDDC, LDWORK, M, N, NC, NCR, NCS, P + DOUBLE PRECISION ALPHA, TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), + $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), + $ DWORK(*), HSVC(*) +C .. Local Scalars .. + LOGICAL BAL, BTA, DISCR, FIXORD, FRWGHT, ISTAB, LEFTW, + $ OSTAB, PERF, RIGHTW, SPA + INTEGER IERR, IWARNL, KI, KR, KT, KTI, KU, KW, LW, MP, + $ NCU, NCU1, NMR, NNC, NRA, WRKOPT + DOUBLE PRECISION ALPWRK, MAXRED, SCALEC, SCALEO +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB09IX, SB16AY, TB01ID, TB01KD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) + SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) + BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) + ISTAB = LSAME( WEIGHT, 'I' ) + OSTAB = LSAME( WEIGHT, 'O' ) + PERF = LSAME( WEIGHT, 'P' ) + LEFTW = OSTAB .OR. PERF + RIGHTW = ISTAB .OR. PERF + FRWGHT = LEFTW .OR. RIGHTW +C + LW = 1 + NNC = N + NC + MP = M + P + IF( FRWGHT ) THEN + LW = NNC*( NNC + 2*MP ) + + $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) + ELSE + LW = NC*( MAX( M, P ) + 5 ) + IF ( LSAME( EQUIL, 'S' ) ) + $ LW = MAX( N, LW ) + END IF + LW = 2*NC*NC + MAX( 1, LW, NC*( 2*NC + 5 ) ) +C +C Check the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -4 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -6 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -7 + ELSE IF( N.LT.0 ) THEN + INFO = -8 + ELSE IF( M.LT.0 ) THEN + INFO = -9 + ELSE IF( P.LT.0 ) THEN + INFO = -10 + ELSE IF( NC.LT.0 ) THEN + INFO = -11 + ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.NC ) ) THEN + INFO = -12 + ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR. + $ ( .NOT.DISCR .AND. ALPHA.GT.ZERO ) ) THEN + INFO = -13 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -21 + ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN + INFO = -23 + ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN + INFO = -25 + ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN + INFO = -27 + ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN + INFO = -29 + ELSE IF( TOL2.GT.ZERO .AND. .NOT.FIXORD .AND. TOL2.GT.TOL1 ) THEN + INFO = -33 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -36 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( NC, M, P ).EQ.0 ) THEN + NCR = 0 + NCS = 0 + IWORK(1) = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C and AC, BC and CC; +C A <- inv(T1)*A*T1, B <- inv(T1)*B and C <- C*T1, where T1 is a +C diagonal matrix; +C AC <- inv(T2)*AC*T2, BC <- inv(T2)*BC and CC <- CC*T2, where T2 +C is a diagonal matrix. +C +C Real workspace: need MAX(N,NC). +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + MAXRED = C100 + CALL TB01ID( 'All', NC, P, M, MAXRED, AC, LDAC, BC, LDBC, + $ CC, LDCC, DWORK, INFO ) + END IF +C +C Correct the value of ALPHA to ensure stability. +C + ALPWRK = ALPHA + IF( DISCR ) THEN + IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) ) + ELSE + IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) ) + END IF +C +C Reduce Ac to a block-diagonal real Schur form, with the +C ALPHA-unstable part in the leading diagonal position, using a +C non-orthogonal similarity transformation, AC <- inv(T)*AC*T, and +C apply the transformation to BC and CC: +C BC <- inv(T)*BC and CC <- CC*T. +C +C Workspace: need NC*(NC+5); +C prefer larger. +C + WRKOPT = 1 + KU = 1 + KR = KU + NC*NC + KI = KR + NC + KW = KI + NC +C + CALL TB01KD( DICO, 'Unstable', 'General', NC, P, M, ALPWRK, + $ AC, LDAC, BC, LDBC, CC, LDCC, NCU, DWORK(KU), NC, + $ DWORK(KR), DWORK(KI), DWORK(KW), LDWORK-KW+1, IERR ) +C + IF( IERR.NE.0 ) THEN + IF( IERR.NE.3 ) THEN + INFO = 5 + ELSE + INFO = 6 + END IF + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C + IWARNL = 0 + NCS = NC - NCU + IF( FIXORD ) THEN + NRA = MAX( 0, NCR-NCU ) + IF( NCR.LT.NCU ) + $ IWARNL = 3 + ELSE + NRA = 0 + END IF +C +C Finish if only unstable part is present. +C + IF( NCS.EQ.0 ) THEN + NCR = NCU + IWORK(1) = 0 + DWORK(1) = WRKOPT + RETURN + END IF +C +C Allocate working storage. +C + KT = 1 + KTI = KT + NC*NC + KW = KTI + NC*NC +C +C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors S and R +C of the frequency-weighted controllability and observability +C Grammians, respectively. +C +C Real workspace: need 2*NC*NC + MAX( 1, LFREQ ), +C where +C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ +C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), +C (M+P)*(M+P+4)) +C if WEIGHT = 'I' or 'O' or 'P'; +C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'; +C prefer larger. +C Integer workspace: 2*(M+P) if WEIGHT = 'I' or 'O' or 'P'; +C 0, if WEIGHT = 'N'. +C + CALL SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, + $ A, LDA, B, LDB, C, LDC, D, LDD, + $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, + $ SCALEC, SCALEO, DWORK(KTI), NC, DWORK(KT), NC, + $ IWORK, DWORK(KW), LDWORK-KW+1, INFO ) + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute a BTA or SPA of the stable part. +C Real workspace: need 2*NC*NC + MAX( 1, 2*NC*NC+5*NC, +C NC*MAX(M,P) ); +C prefer larger. +C Integer workspace: 0, if JOBMR = 'B'; +C NC, if JOBMR = 'F'; +C 2*NC, if JOBMR = 'S' or 'P'. +C + NCU1 = NCU + 1 + CALL AB09IX( DICO, JOBMR, 'Schur', ORDSEL, NCS, P, M, NRA, SCALEC, + $ SCALEO, AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, + $ CC(1,NCU1), LDCC, DC, LDDC, DWORK(KTI), NC, + $ DWORK(KT), NC, NMR, HSVC, TOL1, TOL2, IWORK, + $ DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + IWARN = MAX( IWARN, IWARNL ) + IF( IERR.NE.0 ) THEN + INFO = 7 + RETURN + END IF + NCR = NRA + NCU + IWORK(1) = NMR +C + DWORK(1) = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C + RETURN +C *** Last line of SB16AD *** + END diff --git a/mex/sources/libslicot/SB16AY.f b/mex/sources/libslicot/SB16AY.f new file mode 100644 index 000000000..51438021e --- /dev/null +++ b/mex/sources/libslicot/SB16AY.f @@ -0,0 +1,909 @@ + SUBROUTINE SB16AY( DICO, JOBC, JOBO, WEIGHT, N, M, P, NC, NCS, + $ A, LDA, B, LDB, C, LDC, D, LDD, + $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, + $ SCALEC, SCALEO, S, LDS, R, LDR, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for given state-space representations (A,B,C,D) and +C (Ac,Bc,Cc,Dc) of the transfer-function matrices of the +C open-loop system G and feedback controller K, respectively, +C the Cholesky factors of the frequency-weighted +C controllability and observability Grammians corresponding +C to a frequency-weighted model reduction problem. +C The controller must stabilize the closed-loop system. +C The state matrix Ac must be in a block-diagonal real Schur form +C Ac = diag(Ac1,Ac2), where Ac1 contains the unstable eigenvalues +C of Ac and Ac2 contains the stable eigenvalues of Ac. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the systems as follows: +C = 'C': G and K are continuous-time systems; +C = 'D': G and K are discrete-time systems. +C +C JOBC CHARACTER*1 +C Specifies the choice of frequency-weighted controllability +C Grammian as follows: +C = 'S': choice corresponding to standard Enns' method [1]; +C = 'E': choice corresponding to the stability enhanced +C modified Enns' method of [2]. +C +C JOBO CHARACTER*1 +C Specifies the choice of frequency-weighted observability +C Grammian as follows: +C = 'S': choice corresponding to standard Enns' method [1]; +C = 'E': choice corresponding to the stability enhanced +C modified combination method of [2]. +C +C WEIGHT CHARACTER*1 +C Specifies the type of frequency-weighting, as follows: +C = 'N': no weightings are used (V = I, W = I); +C = 'O': stability enforcing left (output) weighting +C -1 +C V = (I-G*K) *G is used (W = I); +C = 'I': stability enforcing right (input) weighting +C -1 +C W = (I-G*K) *G is used (V = I); +C = 'P': stability and performance enforcing weightings +C -1 -1 +C V = (I-G*K) *G , W = (I-G*K) are used. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the open-loop system state-space +C representation, i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NC (input) INTEGER +C The order of the controller state-space representation, +C i.e., the order of the matrix AC. NC >= 0. +C +C NCS (input) INTEGER +C The dimension of the stable part of the controller, i.e., +C the order of matrix Ac2. NC >= NCS >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system with the transfer-function +C matrix G. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C input/output matrix D of the open-loop system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C AC (input) DOUBLE PRECISION array, dimension (LDAC,NC) +C The leading NC-by-NC part of this array must contain +C the state dynamics matrix Ac of the controller in a +C block diagonal real Schur form Ac = diag(Ac1,Ac2), where +C Ac1 is (NC-NCS)-by-(NC-NCS) and contains the unstable +C eigenvalues of Ac, and Ac2 is NCS-by-NCS and contains +C the stable eigenvalues of Ac. +C +C LDAC INTEGER +C The leading dimension of array AC. LDAC >= MAX(1,NC). +C +C BC (input) DOUBLE PRECISION array, dimension (LDBC,P) +C The leading NC-by-P part of this array must contain +C the input/state matrix Bc of the controller. +C +C LDBC INTEGER +C The leading dimension of array BC. LDBC >= MAX(1,NC). +C +C CC (input) DOUBLE PRECISION array, dimension (LDCC,NC) +C The leading M-by-NC part of this array must contain +C the state/output matrix Cc of the controller. +C +C LDCC INTEGER +C The leading dimension of array CC. LDCC >= MAX(1,M). +C +C DC (input) DOUBLE PRECISION array, dimension (LDDC,P) +C The leading M-by-P part of this array must contain +C the input/output matrix Dc of the controller. +C +C LDDC INTEGER +C The leading dimension of array DC. LDDC >= MAX(1,M). +C +C SCALEC (output) DOUBLE PRECISION +C Scaling factor for the controllability Grammian. +C See METHOD. +C +C SCALEO (output) DOUBLE PRECISION +C Scaling factor for the observability Grammian. See METHOD. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,NCS) +C The leading NCS-by-NCS upper triangular part of this array +C contains the Cholesky factor S of the frequency-weighted +C controllability Grammian P = S*S'. See METHOD. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,NCS). +C +C R (output) DOUBLE PRECISION array, dimension (LDR,NCS) +C The leading NCS-by-NCS upper triangular part of this array +C contains the Cholesky factor R of the frequency-weighted +C observability Grammian Q = R'*R. See METHOD. +C +C LDR INTEGER +C The leading dimension of array R. LDR >= MAX(1,NCS). +C +C Workspace +C +C IWORK INTEGER array, dimension MAX(LIWRK) +C LIWRK = 0, if WEIGHT = 'N'; +C LIWRK = 2(M+P), if WEIGHT = 'O', 'I', or 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, LFREQ ), +C where +C LFREQ = (N+NC)*(N+NC+2*M+2*P)+ +C MAX((N+NC)*(N+NC+MAX(N+NC,M,P)+7), (M+P)*(M+P+4)) +C if WEIGHT = 'I' or 'O' or 'P'; +C LFREQ = NCS*(MAX(M,P)+5) if WEIGHT = 'N'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the closed-loop system is not well-posed; +C its feedthrough matrix is (numerically) singular; +C = 2: the computation of the real Schur form of the +C closed-loop state matrix failed; +C = 3: the closed-loop state matrix is not stable; +C = 4: the solution of a symmetric eigenproblem failed; +C = 5: the NCS-by-NCS trailing part Ac2 of the state +C matrix Ac is not stable or not in a real Schur form. +C +C METHOD +C +C If JOBC = 'S', the controllability Grammian P is determined as +C follows: +C +C - if WEIGHT = 'O' or 'N', P satisfies for a continuous-time +C controller the Lyapunov equation +C +C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0 +C +C and for a discrete-time controller +C +C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0; +C +C - if WEIGHT = 'I' or 'P', let Pi be the solution of the +C continuous-time Lyapunov equation +C +C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0 +C +C or of the discrete-time Lyapunov equation +C +C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0, +C +C where Ai and Bi are the state and input matrices of a special +C state-space realization of the input frequency weight (see [2]); +C P results as the trailing NCS-by-NCS part of Pi partitioned as +C +C Pi = ( * * ). +C ( * P ) +C +C If JOBC = 'E', a modified controllability Grammian P1 >= P is +C determined to guarantee stability for a modified Enns' method [2]. +C +C If JOBO = 'S', the observability Grammian Q is determined as +C follows: +C +C - if WEIGHT = 'I' or 'N', Q satisfies for a continuous-time +C controller the Lyapunov equation +C +C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0 +C +C and for a discrete-time controller +C +C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0; +C +C - if WEIGHT = 'O' or 'P', let Qo be the solution of the +C continuous-time Lyapunov equation +C +C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0 +C +C or of the discrete-time Lyapunov equation +C +C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0, +C +C where Ao and Co are the state and output matrices of a +C special state-space realization of the output frequency weight +C (see [2]); if WEIGHT = 'O', Q results as the leading NCS-by-NCS +C part of Qo partitioned as +C +C Qo = ( Q * ) +C ( * * ) +C +C while if WEIGHT = 'P', Q results as the trailing NCS-by-NCS +C part of Qo partitioned as +C +C Qo = ( * * ). +C ( * Q ) +C +C If JOBO = 'E', a modified observability Grammian Q1 >= Q is +C determined to guarantee stability for a modified Enns' method [2]. +C +C The routine computes directly the Cholesky factors S and R +C such that P = S*S' and Q = R'*R according to formulas +C developed in [2]. +C +C REFERENCES +C +C [1] Enns, D. +C Model reduction with balanced realizations: An error bound +C and a frequency weighted generalization. +C Proc. CDC, Las Vegas, pp. 127-132, 1984. +C +C [2] Varga, A. and Anderson, B.D.O. +C Frequency-weighted balancing related controller reduction. +C Proceedings of the 15th IFAC World Congress, July 21-26, 2002, +C Barcelona, Spain, Vol.15, Part 1, 2002-07-21. +C +C CONTRIBUTORS +C +C A. Varga, Australian National University, Canberra, November 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C May 2009. +C A. Varga, DLR Oberpfafenhofen, June 2001. +C +C +C KEYWORDS +C +C Controller reduction, frequency weighting, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBC, JOBO, WEIGHT + INTEGER INFO, LDA, LDAC, LDB, LDBC, LDC, LDCC, LDD, LDDC, + $ LDR, LDS, LDWORK, M, N, NC, NCS, P + DOUBLE PRECISION SCALEC, SCALEO +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), AC(LDAC,*), B(LDB,*), BC(LDBC,*), + $ C(LDC,*), CC(LDCC,*), D(LDD,*), DC(LDDC,*), + $ DWORK(*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + CHARACTER JOBFAC + LOGICAL DISCR, FRWGHT, LEFTW, PERF, RIGHTW + INTEGER I, IERR, J, JJ, KI, KL, KQ, KR, KTAU, KU, KW, + $ KWA, KWB, KWC, KWD, LDU, LW, MBBAR, ME, MP, + $ NCU, NCU1, NE, NNC, NNCU, PCBAR, PE, WRKOPT + DOUBLE PRECISION RCOND, T, TOL +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL AB05PD, AB05QD, AB07ND, DCOPY, DLACPY, DLASET, + $ DSCAL, DSYEV, MB01WD, MB04OD, SB03OD, SB03OU, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, MIN, SQRT +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + LEFTW = LSAME( WEIGHT, 'O' ) + RIGHTW = LSAME( WEIGHT, 'I' ) + PERF = LSAME( WEIGHT, 'P' ) + FRWGHT = LEFTW .OR. RIGHTW .OR. PERF +C + INFO = 0 + NNC = N + NC + MP = M + P + IF( FRWGHT ) THEN + LW = NNC*( NNC + 2*MP ) + + $ MAX( NNC*( NNC + MAX( NNC, M, P ) + 7 ), MP*( MP + 4 ) ) + ELSE + LW = NCS*( MAX( M, P ) + 5 ) + END IF + LW = MAX( 1, LW ) +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LSAME( JOBC, 'S' ) .OR. LSAME( JOBC, 'E' ) ) ) + $ THEN + INFO = -2 + ELSE IF( .NOT.( LSAME( JOBO, 'S' ) .OR. LSAME( JOBO, 'E' ) ) ) + $ THEN + INFO = -3 + ELSE IF( .NOT.( FRWGHT .OR. LSAME( WEIGHT, 'N' ) ) ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( NC.LT.0 ) THEN + INFO = -8 + ELSE IF( NCS.LT.0 .OR. NCS.GT.NC ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDAC.LT.MAX( 1, NC ) ) THEN + INFO = -19 + ELSE IF( LDBC.LT.MAX( 1, NC ) ) THEN + INFO = -21 + ELSE IF( LDCC.LT.MAX( 1, M ) ) THEN + INFO = -23 + ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN + INFO = -25 + ELSE IF( LDS.LT.MAX( 1, NCS ) ) THEN + INFO = -29 + ELSE IF( LDR.LT.MAX( 1, NCS ) ) THEN + INFO = -31 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -34 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16AY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + SCALEC = ONE + SCALEO = ONE + IF( MIN( NCS, M, P ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + WRKOPT = 1 + NCU = NC - NCS + NCU1 = NCU + 1 +C + IF( .NOT.PERF ) THEN +C +C Compute the Grammians in the case of no weighting or +C one-sided weighting. +C + IF( LEFTW .OR. LSAME( WEIGHT, 'N' ) ) THEN +C +C Compute the standard controllability Grammian. +C +C Solve for the Cholesky factor S of P, P = S*S', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ac2*P + P*Ac2' + scalec^2*Bc2*Bc2' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ac2*P*Ac2' - P + scalec^2*Bc2*Bc2' = 0, +C +C where Bc2 is the matrix formed from the last NCS rows of Bc. +C +C Workspace: need NCS*(P+5); +C prefer larger. + KU = 1 + KTAU = KU + NCS*P + KW = KTAU + NCS +C + CALL DLACPY( 'Full', NCS, P, BC(NCU1,1), LDBC, + $ DWORK(KU), NCS ) + CALL SB03OU( DISCR, .TRUE., NCS, P, AC(NCU1,NCU1), LDAC, + $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, SCALEC, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 5 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C + IF( RIGHTW .OR. LSAME( WEIGHT, 'N' ) ) THEN +C +C Compute the standard observability Grammian. +C +C Solve for the Cholesky factor R of Q, Q = R'*R, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ac2'*Q + Q*Ac2 + scaleo^2*Cc2'*Cc2 = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ac2'*Q*Ac2 - Q + scaleo^2*Cc2'*Cc2 = 0, +C +C where Cc2 is the matrix formed from the last NCS columns +C of Cc. +C +C Workspace: need NCS*(M + 5); +C prefer larger. + KU = 1 + KTAU = KU + M*NCS + KW = KTAU + NCS +C + CALL DLACPY( 'Full', M, NCS, CC(1,NCU1), LDCC, + $ DWORK(KU), M ) + CALL SB03OU( DISCR, .FALSE., NCS, M, AC(NCU1,NCU1), LDAC, + $ DWORK(KU), M, DWORK(KTAU), R, LDR, SCALEO, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 5 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C +C Finish if there are no weights. +C + IF( LSAME( WEIGHT, 'N' ) ) THEN + DWORK(1) = WRKOPT + RETURN + END IF + END IF +C + IF( FRWGHT ) THEN +C +C Allocate working storage for computing the weights. +C +C Real workspace: need MAX(1,NNC*NNC+2*NNC*MP+MP*(MP+4)); +C Integer workspace: need 2*MP. +C + KWA = 1 + KWB = KWA + NNC*NNC + KWC = KWB + NNC*MP + KWD = KWC + NNC*MP + KW = KWD + MP*MP + KL = KWD +C + IF( LEFTW ) THEN +C +C Build the extended matrices +C +C Ao = ( Ac+Bc*inv(R)*D*Cc Bc*inv(R)*C ), +C ( B*inv(Rt)*Cc A+B*Dc*inv(R)*C ) +C +C Co = ( -inv(R)*D*Cc -inv(R)*C ) , +C +C where R = I-D*Dc and Rt = I-Dc*D. +C -1 +C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( K -Im ). +C ( Ge21 Ge22 ) ( -Ip G ) +C +C -1 +C Then Ge11 = -(I-G*K) *G . +C +C Construct first Ge = ( K -Im ) such that the stable part +C ( -Ip G ) +C of K is in the leading position (to avoid updating of +C QR factorization). +C + CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KWD), MP ) + CALL AB05PD( 'N', NCS, P, M, NCU, ONE, + $ AC(NCU1,NCU1), LDAC, BC(NCU1,1), LDBC, + $ CC(1,NCU1), LDCC, DWORK(KWD), MP, + $ AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, + $ NE, DWORK(KWA), NNC, DWORK(KWB), NNC, + $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) + CALL AB05QD( 'Over', NC, P, M, N, M, P, DWORK(KWA), NNC, + $ DWORK(KWB), NNC, DWORK(KWC), MP, DWORK(KWD), + $ MP, A, LDA, B, LDB, C, LDC, D, LDD, + $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, + $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) + CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+MP*P), MP ) + CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+M), MP ) +C + ELSE +C +C Build the extended matrices +C +C Ai = ( A+B*Dc*inv(R)*C B*inv(Rt)*Cc ) , +C ( Bc*inv(R)*C Ac+Bc*inv(R)*D*Cc ) +C +C Bi = ( B*Dc*inv(R) B*inv(Rt) ) , +C ( Bc*inv(R) Bc*D*inv(Rt) ) +C +C Ci = ( -inv(R)*C -inv(R)*D*Cc ) , where +C +C R = I-D*Dc and Rt = I-Dc*D. +C +C -1 +C Method: Compute Ge = ( Ge11 Ge12 ), where Ge = ( G -Ip ). +C ( Ge21 Ge22 ) ( -Im K ) +C +C -1 -1 +C Then Ge22 = -(I-G*K) *G and Ge21 = -(I-G*K) . +C +C Construct first Ge = ( G -Ip ). +C ( -Im K ) +C + CALL AB05QD( 'N', N, M, P, NC, P, M, A, LDA, B, LDB, C, LDC, + $ D, LDD, AC, LDAC, BC, LDBC, CC, LDCC, DC, LDDC, + $ NE, ME, PE, DWORK(KWA), NNC, DWORK(KWB), NNC, + $ DWORK(KWC), MP, DWORK(KWD), MP, IERR ) + CALL DLASET( 'Full', P, P, ZERO, -ONE, DWORK(KWD+MP*M), MP ) + CALL DLASET( 'Full', M, M, ZERO, -ONE, DWORK(KWD+P), MP ) + END IF +C -1 +C Compute Ge = ( Ge11 Ge12 ). +C ( Ge21 Ge22 ) +C +C Additional real workspace: need 4*MP; +C Integer workspace: need 2*MP. +C + CALL AB07ND( NNC, MP, DWORK(KWA), NNC, DWORK(KWB), NNC, + $ DWORK(KWC), MP, DWORK(KWD), MP, RCOND, + $ IWORK, DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C -1 ( A1 | B1 B2 ) +C Partition Ge = (--------------) and select appropriate +C ( C1 | D11 D12 ) +C ( C2 | D21 D22 ) +C +C pointers to matrices and column dimensions to define weights. +C + IF( RIGHTW ) THEN +C +C Define B2 for Ge22. +C + ME = M + KWB = KWB + NNC*P + ELSE IF( PERF ) THEN +C +C Define B1 and C2 for Ge21. +C + ME = P + KWC = KWC + M + END IF + END IF +C + IF( LEFTW .OR. PERF ) THEN +C +C Compute the frequency-weighted observability Grammian. +C +C Solve for the Cholesky factor Ro of Qo, Qo = Ro'*Ro, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ao'*Qo + Qo*Ao + scaleo^2*Co'*Co = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ao'*Qo*Ao - Qo + scaleo^2*Co'*Co = 0. +C +C Additional workspace: need NNC*(NNC+MAX(NNC,P)+7); +C prefer larger. +C + LDU = MAX( NNC, P ) + KU = KL + KQ = KU + NNC*LDU + KR = KQ + NNC*NNC + KI = KR + NNC + KW = KI + NNC +C + JOBFAC = 'N' + CALL DLACPY( 'Full', P, NNC, DWORK(KWC), MP, DWORK(KU), LDU ) + CALL SB03OD( DICO, JOBFAC, 'No-transpose', NNC, P, + $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), LDU, + $ SCALEO, DWORK(KR), DWORK(KI), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.6 ) THEN + INFO = 2 + ELSE + INFO = 3 + END IF + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Partition Ro as Ro = ( R11 R12 ). +C ( 0 R22 ) +C + IF( LEFTW ) THEN +C +C R = R11 (NCS-by-NCS). +C + CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU), LDU, R, LDR ) + ELSE +C +C Compute R such that R'*R = R22'*R22 + R12'*R12, where +C R22 is NCS-by-NCS and R12 is (N+NCU)-by-NCS. +C R22 corresponds to the stable part of the controller. +C + NNCU = N + NCU + CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(LDU+1)*NNCU), LDU, + $ R, LDR ) + KTAU = KU + CALL MB04OD( 'Full', NCS, 0, NNCU, R, LDR, + $ DWORK(KU+LDU*NNCU), LDU, DUM, 1, DUM, 1, + $ DWORK(KTAU), DWORK(KW) ) +C + DO 10 J = 1, NCS + IF( R(J,J).LT.ZERO ) + $ CALL DSCAL( NCS-J+1, -ONE, R(J,J), LDR ) + 10 CONTINUE + END IF + END IF +C + IF( RIGHTW .OR. PERF ) THEN +C +C Compute the frequency-weighted controllability Grammian. +C +C Solve for the Cholesky factor Si of Pi, Pi = Si*Si', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C Ai*Pi + Pi*Ai' + scalec^2*Bi*Bi' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C Ai*Pi*Ai' - Pi + scalec^2*Bi*Bi' = 0. +C +C Additional workspace: need NNC*(NNC+MAX(NNC,P,M)+7); +C prefer larger. +C + KU = KL + KQ = KU + NNC*MAX( NNC, ME ) + KR = KQ + NNC*NNC + KI = KR + NNC + KW = KI + NNC +C + CALL DLACPY( 'Full', NNC, ME, DWORK(KWB), NNC, DWORK(KU), NNC ) + JOBFAC = 'F' + IF( RIGHTW ) JOBFAC = 'N' + CALL SB03OD( DICO, JOBFAC, 'Transpose', NNC, ME, + $ DWORK(KWA), NNC, DWORK(KQ), NNC, DWORK(KU), NNC, + $ SCALEC, DWORK(KR), DWORK(KI), DWORK(KW), + $ LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.6 ) THEN + INFO = 2 + ELSE + INFO = 3 + END IF + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Partition Si as Si = ( S11 S12 ) with S22 NCS-by-NCS and +C ( 0 S22 ) +C set S = S22. +C + NNCU = N + NCU + CALL DLACPY( 'Upper', NCS, NCS, DWORK(KU+(NNC+1)*NNCU), NNC, + $ S, LDS ) + END IF +C + KU = 1 + IF( LEFTW .OR. PERF ) THEN + IF( LSAME( JOBO, 'E' ) ) THEN +C +C Form Y = -Ac2'*(R'*R)-(R'*R)*Ac2 if DICO = 'C', or +C Y = -Ac2'*(R'*R)*Ac2+(R'*R) if DICO = 'D'. +C +C Workspace: need 2*NCS*NCS. +C + CALL DLACPY( 'Upper', NCS, NCS, R, LDR, DWORK(KU), NCS ) + CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, + $ DWORK(KU+NCS*NCS), NCS ) + CALL MB01WD( DICO, 'Upper', 'No-transpose', 'Hessenberg', + $ NCS, -ONE, ZERO, R, LDR, DWORK(KU+NCS*NCS), + $ NCS, DWORK(KU), NCS, IERR ) +C +C Compute the eigendecomposition of Y as Y = Z*Sigma*Z'. +C + KW = KU + NCS + CALL DSYEV( 'Vectors', 'Upper', NCS, R, LDR, DWORK(KU), + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 4 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Partition Sigma = (Sigma1,Sigma2), such that +C Sigma1 <= 0, Sigma2 > 0. +C Partition correspondingly Z = [Z1 Z2]. +C + TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) + $ * DLAMCH( 'Epsilon') +C _ +C Form Cc = [ sqrt(Sigma2)*Z2' ] +C + PCBAR = 0 + JJ = KU + DO 20 J = 1, NCS + IF( DWORK(JJ).GT.TOL ) THEN + CALL DSCAL( NCS, SQRT( DWORK(JJ) ), R(1,J), 1 ) + CALL DCOPY( NCS, R(1,J), 1, DWORK(KW+PCBAR), NCS ) + PCBAR = PCBAR + 1 + END IF + JJ = JJ + 1 + 20 CONTINUE +C +C Solve for the Cholesky factor R of Q, Q = R'*R, +C the continuous-time Lyapunov equation (if DICO = 'C') +C _ _ +C Ac2'*Q + Q*Ac2 + scaleo^2*Cc'*Cc = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C _ _ +C Ac2'*Q*Ac2 - Q + scaleo^2*Cc'*Cc = 0. +C +C Workspace: need NCS*(NCS + 6); +C prefer larger. +C + KU = KW + KTAU = KU + NCS*NCS + KW = KTAU + NCS +C + CALL SB03OU( DISCR, .FALSE., NCS, PCBAR, AC(NCU1,NCU1), + $ LDAC, DWORK(KU), NCS, DWORK(KTAU), R, LDR, T, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 5 + RETURN + END IF + SCALEO = SCALEO*T + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C + END IF +C + IF( RIGHTW .OR. PERF ) THEN + IF( LSAME( JOBC, 'E' ) ) THEN +C +C Form X = -A2c*(S*S')-(S*S')*Ac2' if DICO = 'C', or +C X = -Ac2*(S*S')*Ac2'+(S*S') if DICO = 'D'. +C +C Workspace: need 2*NCS*NCS. +C + CALL DLACPY( 'Upper', NCS, NCS, S, LDS, DWORK(KU), NCS ) + CALL DLACPY( 'Full', NCS, NCS, AC(NCU1,NCU1), LDAC, + $ DWORK(KU+NCS*NCS), NCS ) + CALL MB01WD( DICO, 'Upper', 'Transpose', 'Hessenberg', NCS, + $ -ONE, ZERO, S, LDS, DWORK(KU+NCS*NCS), NCS, + $ DWORK(KU), NCS, IERR ) +C +C Compute the eigendecomposition of X as X = Z*Sigma*Z'. +C + KW = KU + NCS + CALL DSYEV( 'Vectors', 'Upper', NCS, S, LDS, DWORK(KU), + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.GT.0 ) THEN + INFO = 4 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Partition Sigma = (Sigma1,Sigma2), such that +C Sigma1 =< 0, Sigma2 > 0. +C Partition correspondingly Z = [Z1 Z2]. +C + TOL = MAX( ABS( DWORK(KU) ), ABS( DWORK(KU+NCS-1) ) ) + $ * DLAMCH( 'Epsilon') +C _ +C Form Bc = [ Z2*sqrt(Sigma2) ] +C + MBBAR = 0 + I = KW + JJ = KU + DO 30 J = 1, NCS + IF( DWORK(JJ).GT.TOL ) THEN + MBBAR = MBBAR + 1 + CALL DSCAL( NCS, SQRT( DWORK(JJ) ), S(1,J), 1 ) + CALL DCOPY( NCS, S(1,J), 1, DWORK(I), 1 ) + I = I + NCS + END IF + JJ = JJ + 1 + 30 CONTINUE +C +C Solve for the Cholesky factor S of P, P = S*S', +C the continuous-time Lyapunov equation (if DICO = 'C') +C _ _ +C Ac2*P + P*Ac2' + scalec^2*Bc*Bc' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C _ _ +C Ac2*P*Ac2' - P + scalec^2*Bc*Bc' = 0. +C +C Workspace: need maximum NCS*(NCS + 6); +C prefer larger. +C + KU = KW + KTAU = KU + MBBAR*NCS + KW = KTAU + NCS +C + CALL SB03OU( DISCR, .TRUE., NCS, MBBAR, AC(NCU1,NCU1), LDAC, + $ DWORK(KU), NCS, DWORK(KTAU), S, LDS, T, + $ DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 5 + RETURN + END IF + SCALEC = SCALEC*T + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C + END IF +C +C Save optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB16AY *** + END diff --git a/mex/sources/libslicot/SB16BD.f b/mex/sources/libslicot/SB16BD.f new file mode 100644 index 000000000..0141f1d0c --- /dev/null +++ b/mex/sources/libslicot/SB16BD.f @@ -0,0 +1,652 @@ + SUBROUTINE SB16BD( DICO, JOBD, JOBMR, JOBCF, EQUIL, ORDSEL, + $ N, M, P, NCR, A, LDA, B, LDB, C, LDC, D, LDD, + $ F, LDF, G, LDG, DC, LDDC, HSV, TOL1, TOL2, + $ IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a given open-loop model (A,B,C,D), and for +C given state feedback gain F and full observer gain G, +C such that A+B*F and A+G*C are stable, a reduced order +C controller model (Ac,Bc,Cc,Dc) using a coprime factorization +C based controller reduction approach. For reduction, +C either the square-root or the balancing-free square-root +C versions of the Balance & Truncate (B&T) or Singular Perturbation +C Approximation (SPA) model reduction methods are used in +C conjunction with stable coprime factorization techniques. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the open-loop system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears +C in the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root B&T method; +C = 'F': use the balancing-free square-root B&T method; +C = 'S': use the square-root SPA method; +C = 'P': use the balancing-free square-root SPA method. +C +C JOBCF CHARACTER*1 +C Specifies whether left or right coprime factorization is +C to be used as follows: +C = 'L': use left coprime factorization; +C = 'R': use right coprime factorization. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to perform a +C preliminary equilibration before performing +C order reduction as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting controller order NCR is fixed; +C = 'A': the resulting controller order NCR is +C automatically determined on basis of the given +C tolerance TOL1. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the open-loop state-space representation, +C i.e., the order of the matrix A. N >= 0. +C N also represents the order of the original state-feedback +C controller. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NCR (input/output) INTEGER +C On entry with ORDSEL = 'F', NCR is the desired order of +C the resulting reduced order controller. 0 <= NCR <= N. +C On exit, if INFO = 0, NCR is the order of the resulting +C reduced order controller. NCR is set as follows: +C if ORDSEL = 'F', NCR is equal to MIN(NCR,NMIN), where NCR +C is the desired order on entry, and NMIN is the order of a +C minimal realization of an extended system Ge (see METHOD); +C NMIN is determined as the number of +C Hankel singular values greater than N*EPS*HNORM(Ge), +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH) and HNORM(Ge) is the Hankel norm of the +C extended system (computed in HSV(1)); +C if ORDSEL = 'A', NCR is equal to the number of Hankel +C singular values greater than MAX(TOL1,N*EPS*HNORM(Ge)). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if INFO = 0, the leading NCR-by-NCR part of this +C array contains the state dynamics matrix Ac of the reduced +C controller. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must +C contain the original input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must +C contain the original state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this +C array must contain the system direct input/output +C transmission matrix D. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) +C On entry, the leading M-by-N part of this array must +C contain a stabilizing state feedback matrix. +C On exit, if INFO = 0, the leading M-by-NCR part of this +C array contains the state/output matrix Cc of the reduced +C controller. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) +C On entry, the leading N-by-P part of this array must +C contain a stabilizing observer gain matrix. +C On exit, if INFO = 0, the leading NCR-by-P part of this +C array contains the input/state matrix Bc of the reduced +C controller. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C DC (output) DOUBLE PRECISION array, dimension (LDDC,P) +C If INFO = 0, the leading M-by-P part of this array +C contains the input/output matrix Dc of the reduced +C controller. +C +C LDDC INTEGER +C The leading dimension of array DC. LDDC >= MAX(1,M). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, it contains the N Hankel singular values +C of the extended system ordered decreasingly (see METHOD). +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C If ORDSEL = 'A', TOL1 contains the tolerance for +C determining the order of the reduced extended system. +C For model reduction, the recommended value is +C TOL1 = c*HNORM(Ge), where c is a constant in the +C interval [0.00001,0.001], and HNORM(Ge) is the +C Hankel norm of the extended system (computed in HSV(1)). +C The value TOL1 = N*EPS*HNORM(Ge) is used by default if +C TOL1 <= 0 on entry, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL1 is ignored. +C +C TOL2 DOUBLE PRECISION +C The tolerance for determining the order of a minimal +C realization of the coprime factorization controller +C (see METHOD). The recommended value is +C TOL2 = N*EPS*HNORM(Ge) (see METHOD). +C This value is used by default if TOL2 <= 0 on entry. +C If TOL2 > 0 and ORDSEL = 'A', then TOL2 <= TOL1. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK = 0, if ORDSEL = 'F' and NCR = N. +C Otherwise, +C LIWORK = MAX(PM,M), if JOBCF = 'L', +C LIWORK = MAX(PM,P), if JOBCF = 'R', where +C PM = 0, if JOBMR = 'B', +C PM = N, if JOBMR = 'F', +C PM = MAX(1,2*N), if JOBMR = 'S' or 'P'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= P*N, if ORDSEL = 'F' and NCR = N. Otherwise, +C LDWORK >= (N+M)*(M+P) + MAX(LWR,4*M), if JOBCF = 'L', +C LDWORK >= (N+P)*(M+P) + MAX(LWR,4*P), if JOBCF = 'R', +C where LWR = MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NCR is +C greater than the order of a minimal +C realization of the controller. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the reduction of A+G*C to a real Schur form +C failed; +C = 2: the matrix A+G*C is not stable (if DICO = 'C'), +C or not convergent (if DICO = 'D'); +C = 3: the computation of Hankel singular values failed; +C = 4: the reduction of A+B*F to a real Schur form +C failed; +C = 5: the matrix A+B*F is not stable (if DICO = 'C'), +C or not convergent (if DICO = 'D'). +C +C METHOD +C +C Let be the linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let Go(d) be the open-loop +C transfer-function matrix +C -1 +C Go(d) = C*(d*I-A) *B + D . +C +C Let F and G be the state feedback and observer gain matrices, +C respectively, chosen so that A+B*F and A+G*C are stable matrices. +C The controller has a transfer-function matrix K(d) given by +C -1 +C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . +C +C The closed-loop transfer-function matrix is given by +C -1 +C Gcl(d) = Go(d)(I+K(d)Go(d)) . +C +C K(d) can be expressed as a left coprime factorization (LCF), +C -1 +C K(d) = M_left(d) *N_left(d) , +C +C or as a right coprime factorization (RCF), +C -1 +C K(d) = N_right(d)*M_right(d) , +C +C where M_left(d), N_left(d), N_right(d), and M_right(d) are +C stable transfer-function matrices. +C +C The subroutine SB16BD determines the matrices of a reduced +C controller +C +C d[z(t)] = Ac*z(t) + Bc*y(t) +C u(t) = Cc*z(t) + Dc*y(t), (2) +C +C with the transfer-function matrix Kr as follows: +C +C (1) If JOBCF = 'L', the extended system +C Ge(d) = [ N_left(d) M_left(d) ] is reduced to +C Ger(d) = [ N_leftr(d) M_leftr(d) ] by using either the +C B&T or SPA methods. The reduced order controller Kr(d) +C is computed as +C -1 +C Kr(d) = M_leftr(d) *N_leftr(d) ; +C +C (2) If JOBCF = 'R', the extended system +C Ge(d) = [ N_right(d) ] is reduced to +C [ M_right(d) ] +C Ger(d) = [ N_rightr(d) ] by using either the +C [ M_rightr(d) ] +C B&T or SPA methods. The reduced order controller Kr(d) +C is computed as +C -1 +C Kr(d) = N_rightr(d)* M_rightr(d) . +C +C If ORDSEL = 'A', the order of the controller is determined by +C computing the number of Hankel singular values greater than +C the given tolerance TOL1. The Hankel singular values are +C the square roots of the eigenvalues of the product of +C the controllability and observability Grammians of the +C extended system Ge. +C +C If JOBMR = 'B', the square-root B&T method of [1] is used. +C +C If JOBMR = 'F', the balancing-free square-root version of the +C B&T method [1] is used. +C +C If JOBMR = 'S', the square-root version of the SPA method [2,3] +C is used. +C +C If JOBMR = 'P', the balancing-free square-root version of the +C SPA method [2,3] is used. +C +C REFERENCES +C +C [1] Tombs, M.S. and Postlethwaite, I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [2] Varga, A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, +C pp. 42-46, 1991. +C +C [3] Varga, A. +C Coprime factors model reduction method based on square-root +C balancing-free techniques. +C System Analysis, Modelling and Simulation, Vol. 11, +C pp. 303-311, 1993. +C +C [4] Liu, Y., Anderson, B.D.O. and Ly, O.L. +C Coprime factorization controller reduction with Bezout +C identity induced frequency weighting. +C Automatica, vol. 26, pp. 233-249, 1990. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, August 2000. +C D. Sima, University of Bucharest, August 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Dec. 2000, +C Aug. 2001. +C +C KEYWORDS +C +C Balancing, controller reduction, coprime factorization, +C minimal realization, multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, EQUIL, JOBCF, JOBD, JOBMR, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, LDDC, + $ LDF, LDG, LDWORK, M, N, NCR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DC(LDDC,*), DWORK(*), F(LDF,*), G(LDG,*), HSV(*) +C .. Local Scalars .. + CHARACTER JOB + LOGICAL BAL, BTA, DISCR, FIXORD, LEFT, LEQUIL, SPA, + $ WITHD + INTEGER KBE, KCE, KDE, KW, LDBE, LDCE, LDDE, LW1, LW2, + $ LWR, MAXMP, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09AD, AB09BD, DGEMM, DLACPY, DLASET, SB08GD, + $ SB08HD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + WITHD = LSAME( JOBD, 'D' ) + BTA = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'F' ) + SPA = LSAME( JOBMR, 'S' ) .OR. LSAME( JOBMR, 'P' ) + BAL = LSAME( JOBMR, 'B' ) .OR. LSAME( JOBMR, 'S' ) + LEFT = LSAME( JOBCF, 'L' ) + LEQUIL = LSAME( EQUIL, 'S' ) + FIXORD = LSAME( ORDSEL, 'F' ) + MAXMP = MAX( M, P ) +C + LWR = MAX( 1, N*( 2*N + MAX( N, M+P ) + 5 ) + ( N*(N+1) )/2 ) + LW1 = (N+M)*(M+P) + MAX( LWR, 4*M ) + LW2 = (N+P)*(M+P) + MAX( LWR, 4*P ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( BTA .OR. SPA ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( LEQUIL .OR. LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -5 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( M.LT.0 ) THEN + INFO = -8 + ELSE IF( P.LT.0 ) THEN + INFO = -9 + ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN + INFO = -10 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -18 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -20 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -22 + ELSE IF( LDDC.LT.MAX( 1, M ) ) THEN + INFO = -24 + ELSE IF( .NOT.FIXORD .AND. TOL2.GT.ZERO .AND. TOL2.GT.TOL1 ) THEN + INFO = -27 + ELSE IF( ( ( .NOT.FIXORD .OR. NCR.LT.N ) .AND. + $ ( ( LEFT .AND. LDWORK.LT.LW1 ) ) .OR. + $ ( .NOT.LEFT .AND. LDWORK.LT.LW2 ) ) .OR. + $ ( FIXORD .AND. NCR.EQ.N .AND. LDWORK.LT.P*N ) ) THEN + INFO = -30 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16BD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. + $ ( FIXORD .AND. BTA .AND. NCR.EQ.0 ) ) THEN + NCR = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF( NCR.EQ.N ) THEN +C +C Form the controller state matrix, +C Ac = A + B*F + G*C + G*D*F = A + B*F + G*(C+D*F) . +C Real workspace: need P*N. +C Integer workspace: need 0. +C + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) + IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, + $ ONE, D, LDD, F, LDF, ONE, + $ DWORK, P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, + $ LDG, DWORK, P, ONE, A, LDA ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, + $ LDB, F, LDF, ONE, A, LDA ) +C + DWORK(1) = P*N + RETURN + END IF +C + IF( BAL ) THEN + JOB = 'B' + ELSE + JOB = 'N' + END IF +C +C Reduce the coprime factors. +C + IF( LEFT ) THEN +C +C Form Ge(d) = [ N_left(d) M_left(d) ] as +C +C ( A+G*C | G B+GD ) +C (------------------) +C ( F | 0 I ) +C +C Real workspace: need (N+M)*(M+P). +C Integer workspace: need 0. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, P, ONE, G, + $ LDG, C, LDC, ONE, A, LDA ) + KBE = 1 + KDE = KBE + N*(P+M) + LDBE = MAX( 1, N ) + LDDE = M + CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KBE), LDBE ) + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KBE+N*P), LDBE ) + IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, P, + $ ONE, G, LDG, D, LDD, ONE, + $ DWORK(KBE+N*P), LDBE ) + CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) + CALL DLASET( 'Full', M, M, ZERO, ONE, DWORK(KDE+M*P), LDDE ) +C +C Compute the reduced coprime factors, +C Ger(d) = [ N_leftr(d) M_leftr(d) ] , +C by using either the B&T or SPA methods. +C +C Real workspace: need (N+M)*(M+P) + +C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). +C Integer workspace: need 0, if JOBMR = 'B', +C N, if JOBMR = 'F', and +C MAX(1,2*N) if JOBMR = 'S' or 'P'. +C + KW = KDE + M*(P+M) + IF( BTA ) THEN + CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, + $ LDA, DWORK(KBE), LDBE, F, LDF, HSV, TOL1, + $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) + ELSE + CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, M+P, M, NCR, A, + $ LDA, DWORK(KBE), LDBE, F, LDF, DWORK(KDE), + $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), + $ LDWORK-KW+1, IWARN, INFO ) + END IF + IF( INFO.NE.0 ) + $ RETURN +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Compute the reduced order controller, +C -1 +C Kr(d) = M_leftr(d) *N_leftr(d). +C +C Real workspace: need (N+M)*(M+P) + MAX(1,4*M). +C Integer workspace: need M. +C + CALL SB08GD( NCR, P, M, A, LDA, DWORK(KBE), LDBE, F, LDF, + $ DWORK(KDE), LDDE, DWORK(KBE+N*P), LDBE, + $ DWORK(KDE+M*P), LDDE, IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Bc and Dc. +C + CALL DLACPY( 'Full', NCR, P, DWORK(KBE), LDBE, G, LDG ) + CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) +C + ELSE +C +C Form Ge(d) = [ N_right(d) ] +C [ M_right(d) ] as +C +C ( A+B*F | G ) +C (-----------) +C ( F | 0 ) +C ( C+D*F | I ) +C +C Real workspace: need (N+P)*(M+P). +C Integer workspace: need 0. +C + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, M, ONE, B, + $ LDB, F, LDF, ONE, A, LDA ) + KCE = 1 + KDE = KCE + N*(P+M) + LDCE = M+P + LDDE = LDCE + CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KCE), LDCE ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KCE+M), LDCE ) + IF( WITHD ) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, N, M, + $ ONE, D, LDD, F, LDF, ONE, + $ DWORK(KCE+M), LDCE ) + CALL DLASET( 'Full', M, P, ZERO, ZERO, DWORK(KDE), LDDE ) + CALL DLASET( 'Full', P, P, ZERO, ONE, DWORK(KDE+M), LDDE ) +C +C Compute the reduced coprime factors, +C Ger(d) = [ N_rightr(d) ] +C [ M_rightr(d) ], +C by using either the B&T or SPA methods. +C +C Real workspace: need (N+P)*(M+P) + +C MAX(1,N*(2*N+MAX(N,M+P)+5)+N*(N+1)/2). +C Integer workspace: need 0, if JOBMR = 'B', +C N, if JOBMR = 'F', and +C MAX(1,2*N) if JOBMR = 'S' or 'P'. +C + KW = KDE + P*(P+M) + IF( BTA ) THEN + CALL AB09AD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, + $ LDA, G, LDG, DWORK(KCE), LDCE, HSV, TOL1, + $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, INFO ) + ELSE + CALL AB09BD( DICO, JOB, EQUIL, ORDSEL, N, P, M+P, NCR, A, + $ LDA, G, LDG, DWORK(KCE), LDCE, DWORK(KDE), + $ LDDE, HSV, TOL1, TOL2, IWORK, DWORK(KW), + $ LDWORK-KW+1, IWARN, INFO ) + END IF + IF( INFO.NE.0 ) THEN + IF( INFO.NE.3 ) INFO = INFO + 3 + RETURN + END IF +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Compute the reduced order controller, +C -1 +C Kr(d) = N_rightr(d)*M_rightr(d) . +C +C Real workspace: need (N+P)*(M+P) + MAX(1,4*P). +C Integer workspace: need P. +C + CALL SB08HD( NCR, P, M, A, LDA, G, LDG, DWORK(KCE), LDCE, + $ DWORK(KDE), LDDE, DWORK(KCE+M), LDCE, + $ DWORK(KDE+M), LDDE, IWORK, DWORK(KW), INFO ) +C +C Copy the reduced system matrices Cc and Dc. +C + CALL DLACPY( 'Full', M, NCR, DWORK(KCE), LDCE, F, LDF ) + CALL DLACPY( 'Full', M, P, DWORK(KDE), LDDE, DC, LDDC ) +C + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB16BD *** + END diff --git a/mex/sources/libslicot/SB16CD.f b/mex/sources/libslicot/SB16CD.f new file mode 100644 index 000000000..677a916d7 --- /dev/null +++ b/mex/sources/libslicot/SB16CD.f @@ -0,0 +1,526 @@ + SUBROUTINE SB16CD( DICO, JOBD, JOBMR, JOBCF, ORDSEL, N, M, P, NCR, + $ A, LDA, B, LDB, C, LDC, D, LDD, F, LDF, G, LDG, + $ HSV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a given open-loop model (A,B,C,D), and for +C given state feedback gain F and full observer gain G, +C such that A+B*F and A+G*C are stable, a reduced order +C controller model (Ac,Bc,Cc) using a coprime factorization +C based controller reduction approach. For reduction of +C coprime factors, a stability enforcing frequency-weighted +C model reduction is performed using either the square-root or +C the balancing-free square-root versions of the Balance & Truncate +C (B&T) model reduction method. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the open-loop system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears +C in the given state space model, as follows: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C JOBMR CHARACTER*1 +C Specifies the model reduction approach to be used +C as follows: +C = 'B': use the square-root B&T method; +C = 'F': use the balancing-free square-root B&T method. +C +C JOBCF CHARACTER*1 +C Specifies whether left or right coprime factorization +C of the controller is to be used as follows: +C = 'L': use left coprime factorization; +C = 'R': use right coprime factorization. +C +C ORDSEL CHARACTER*1 +C Specifies the order selection method as follows: +C = 'F': the resulting controller order NCR is fixed; +C = 'A': the resulting controller order NCR is +C automatically determined on basis of the given +C tolerance TOL. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C N also represents the order of the original state-feedback +C controller. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NCR (input/output) INTEGER +C On entry with ORDSEL = 'F', NCR is the desired order of +C the resulting reduced order controller. 0 <= NCR <= N. +C On exit, if INFO = 0, NCR is the order of the resulting +C reduced order controller. NCR is set as follows: +C if ORDSEL = 'F', NCR is equal to MIN(NCR,NCRMIN), where +C NCR is the desired order on entry, and NCRMIN is the +C number of Hankel-singular values greater than N*EPS*S1, +C where EPS is the machine precision (see LAPACK Library +C Routine DLAMCH) and S1 is the largest Hankel singular +C value (computed in HSV(1)); NCR can be further reduced +C to ensure HSV(NCR) > HSV(NCR+1); +C if ORDSEL = 'A', NCR is equal to the number of Hankel +C singular values greater than MAX(TOL,N*EPS*S1). +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if INFO = 0, the leading NCR-by-NCR part of this +C array contains the state dynamics matrix Ac of the reduced +C controller. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the open-loop system input/state matrix B. +C On exit, this array is overwritten with a NCR-by-M +C B&T approximation of the matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the open-loop system state/output matrix C. +C On exit, this array is overwritten with a P-by-NCR +C B&T approximation of the matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the system direct input/output +C transmission matrix D. +C The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C F (input/output) DOUBLE PRECISION array, dimension (LDF,N) +C On entry, the leading M-by-N part of this array must +C contain a stabilizing state feedback matrix. +C On exit, if INFO = 0, the leading M-by-NCR part of this +C array contains the output/state matrix Cc of the reduced +C controller. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C G (input/output) DOUBLE PRECISION array, dimension (LDG,P) +C On entry, the leading N-by-P part of this array must +C contain a stabilizing observer gain matrix. +C On exit, if INFO = 0, the leading NCR-by-P part of this +C array contains the input/state matrix Bc of the reduced +C controller. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C HSV (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, HSV contains the N frequency-weighted +C Hankel singular values ordered decreasingly (see METHOD). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C If ORDSEL = 'A', TOL contains the tolerance for +C determining the order of reduced controller. +C The recommended value is TOL = c*S1, where c is a constant +C in the interval [0.00001,0.001], and S1 is the largest +C Hankel singular value (computed in HSV(1)). +C The value TOL = N*EPS*S1 is used by default if +C TOL <= 0 on entry, where EPS is the machine precision +C (see LAPACK Library Routine DLAMCH). +C If ORDSEL = 'F', the value of TOL is ignored. +C +C Workspace +C +C IWORK INTEGER array, dimension LIWORK, where +C LIWORK = 0, if JOBMR = 'B'; +C LIWORK = N, if JOBMR = 'F'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX(M,P), +C N*(N + MAX(N,MP) + MIN(N,MP) + 6)), +C where MP = M, if JOBCF = 'L'; +C MP = P, if JOBCF = 'R'. +C For optimum performance LDWORK should be larger. +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: with ORDSEL = 'F', the selected order NCR is +C greater than the order of a minimal realization +C of the controller; +C = 2: with ORDSEL = 'F', the selected order NCR +C corresponds to repeated singular values, which are +C neither all included nor all excluded from the +C reduced controller. In this case, the resulting NCR +C is set automatically to the largest value such that +C HSV(NCR) > HSV(NCR+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: eigenvalue computation failure; +C = 2: the matrix A+G*C is not stable; +C = 3: the matrix A+B*F is not stable; +C = 4: the Lyapunov equation for computing the +C observability Grammian is (nearly) singular; +C = 5: the Lyapunov equation for computing the +C controllability Grammian is (nearly) singular; +C = 6: the computation of Hankel singular values failed. +C +C METHOD +C +C Let be the linear system +C +C d[x(t)] = Ax(t) + Bu(t) +C y(t) = Cx(t) + Du(t), (1) +C +C where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1) +C for a discrete-time system, and let Go(d) be the open-loop +C transfer-function matrix +C -1 +C Go(d) = C*(d*I-A) *B + D . +C +C Let F and G be the state feedback and observer gain matrices, +C respectively, chosen such that A+BF and A+GC are stable matrices. +C The controller has a transfer-function matrix K(d) given by +C -1 +C K(d) = F*(d*I-A-B*F-G*C-G*D*F) *G . +C +C The closed-loop transfer function matrix is given by +C -1 +C Gcl(d) = Go(d)(I+K(d)Go(d)) . +C +C K(d) can be expressed as a left coprime factorization (LCF) +C -1 +C K(d) = M_left(d) *N_left(d), +C +C or as a right coprime factorization (RCF) +C -1 +C K(d) = N_right(d)*M_right(d) , +C +C where M_left(d), N_left(d), N_right(d), and M_right(d) are +C stable transfer-function matrices. +C +C The subroutine SB16CD determines the matrices of a reduced +C controller +C +C d[z(t)] = Ac*z(t) + Bc*y(t) +C u(t) = Cc*z(t), (2) +C +C with the transfer-function matrix Kr, using the following +C stability enforcing approach proposed in [1]: +C +C (1) If JOBCF = 'L', the frequency-weighted approximation problem +C is solved +C +C min||[M_left(d)-M_leftr(d) N_left(d)-N_leftr(d)][-Y(d)]|| , +C [ X(d)] +C where +C -1 +C G(d) = Y(d)*X(d) +C +C is a RCF of the open-loop system transfer-function matrix. +C The B&T model reduction technique is used in conjunction +C with the method proposed in [1]. +C +C (2) If JOBCF = 'R', the frequency-weighted approximation problem +C is solved +C +C min || [ -U(d) V(d) ] [ N_right(d)-N_rightr(d) ] || , +C [ M_right(d)-M_rightr(d) ] +C where +C -1 +C G(d) = V(d) *U(d) +C +C is a LCF of the open-loop system transfer-function matrix. +C The B&T model reduction technique is used in conjunction +C with the method proposed in [1]. +C +C If ORDSEL = 'A', the order of the controller is determined by +C computing the number of Hankel singular values greater than +C the given tolerance TOL. The Hankel singular values are +C the square roots of the eigenvalues of the product of +C two frequency-weighted Grammians P and Q, defined as follows. +C +C If JOBCF = 'L', then P is the controllability Grammian of a system +C of the form (A+BF,B,*,*), and Q is the observability Grammian of a +C system of the form (A+GC,*,F,*). This choice corresponds to an +C input frequency-weighted order reduction of left coprime +C factors [1]. +C +C If JOBCF = 'R', then P is the controllability Grammian of a system +C of the form (A+BF,G,*,*), and Q is the observability Grammian of a +C system of the form (A+GC,*,C,*). This choice corresponds to an +C output frequency-weighted order reduction of right coprime +C factors [1]. +C +C For the computation of truncation matrices, the B&T approach +C is used in conjunction with accuracy enhancing techniques. +C If JOBMR = 'B', the square-root B&T method of [2,4] is used. +C If JOBMR = 'F', the balancing-free square-root version of the +C B&T method [3,4] is used. +C +C REFERENCES +C +C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. +C Coprime factorization controller reduction with Bezout +C identity induced frequency weighting. +C Automatica, vol. 26, pp. 233-249, 1990. +C +C [2] Tombs, M.S. and Postlethwaite I. +C Truncated balanced realization of stable, non-minimal +C state-space systems. +C Int. J. Control, Vol. 46, pp. 1319-1330, 1987. +C +C [3] Varga, A. +C Efficient minimal realization procedure based on balancing. +C Proc. of IMACS/IFAC Symp. MCTS, Lille, France, May 1991, +C A. El Moudui, P. Borne, S. G. Tzafestas (Eds.), Vol. 2, +C pp. 42-46, 1991. +C +C [4] Varga, A. +C Coprime factors model reduction method based on square-root +C balancing-free techniques. +C System Analysis, Modelling and Simulation, Vol. 11, +C pp. 303-311, 1993. +C +C NUMERICAL ASPECTS +C +C The implemented methods rely on accuracy enhancing square-root or +C balancing-free square-root techniques. +C 3 +C The algorithms require less than 30N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. +C D. Sima, University of Bucharest, October 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Aug. 2001. +C +C KEYWORDS +C +C Controller reduction, coprime factorization, frequency weighting, +C multivariable system, state-space model. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBCF, JOBD, JOBMR, ORDSEL + INTEGER INFO, IWARN, LDA, LDB, LDC, LDD, + $ LDF, LDG, LDWORK, M, N, NCR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), F(LDF,*), G(LDG,*), HSV(*) +C .. Local Scalars .. + LOGICAL BAL, DISCR, FIXORD, LEFT, WITHD + INTEGER IERR, KT, KTI, KW, LW, MP, NMR, WRKOPT + DOUBLE PRECISION SCALEC, SCALEO +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB09IX, DGEMM, DLACPY, SB16CY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + IWARN = 0 + DISCR = LSAME( DICO, 'D' ) + WITHD = LSAME( JOBD, 'D' ) + BAL = LSAME( JOBMR, 'B' ) + LEFT = LSAME( JOBCF, 'L' ) + FIXORD = LSAME( ORDSEL, 'F' ) + IF( LEFT ) THEN + MP = M + ELSE + MP = P + END IF + LW = 2*N*N + MAX( 1, 2*N*N + 5*N, N*MAX( M, P ), + $ N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) ) +C +C Test the input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( WITHD .OR. LSAME( JOBD, 'Z' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( BAL .OR. LSAME( JOBMR, 'F' ) ) ) THEN + INFO = -3 + ELSE IF( .NOT. ( LEFT .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -4 + ELSE IF( .NOT. ( FIXORD .OR. LSAME( ORDSEL, 'A' ) ) ) THEN + INFO = -5 + ELSE IF( N.LT.0 ) THEN + INFO = -6 + ELSE IF( M.LT.0 ) THEN + INFO = -7 + ELSE IF( P.LT.0 ) THEN + INFO = -8 + ELSE IF( FIXORD .AND. ( NCR.LT.0 .OR. NCR.GT.N ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -17 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -19 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -21 + ELSE IF( LDWORK.LT.LW ) THEN + INFO = -26 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 .OR. + $ ( FIXORD .AND. NCR.EQ.0 ) ) THEN + NCR = 0 + DWORK(1) = ONE + RETURN + END IF +C +C Allocate working storage. +C + KT = 1 + KTI = KT + N*N + KW = KTI + N*N +C +C Compute in DWORK(KTI) and DWORK(KT) the Cholesky factors Su and Ru +C of the frequency-weighted controllability and observability +C Grammians, respectively. +C +C Workspace: need 2*N*N + MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), +C if JOBCF = 'L'; +C 2*N*N + MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), +C if JOBCF = 'R'. +C prefer larger. +C + CALL SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, + $ F, LDF, G, LDG, SCALEC, SCALEO, DWORK(KTI), N, + $ DWORK(KT), N, DWORK(KW), LDWORK-KW+1, INFO ) +C + IF( INFO.NE.0 ) + $ RETURN + WRKOPT = INT( DWORK(KW) ) + KW - 1 +C +C Compute a B&T approximation (Ar,Br,Cr) of (A,B,C) and +C the corresponding truncation matrices TI and T. +C +C Real workspace: need 2*N*N + MAX( 1, 2*N*N+5*N, N*MAX(M,P) ); +C prefer larger. +C Integer workspace: 0, if JOBMR = 'B'; +C N, if JOBMR = 'F'. +C + CALL AB09IX( DICO, JOBMR, 'NotSchur', ORDSEL, N, M, P, NCR, + $ SCALEC, SCALEO, A, LDA, B, LDB, C, LDC, D, LDD, + $ DWORK(KTI), N, DWORK(KT), N, NMR, HSV, TOL, TOL, + $ IWORK, DWORK(KW), LDWORK-KW+1, IWARN, IERR ) + IF( IERR.NE.0 ) THEN + INFO = 6 + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Compute reduced gains Bc = Gr = TI*G and Cc = Fr = F*T. +C Workspace: need N*(2*N+MAX(M,P)). +C + CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KW), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, P, N, ONE, + $ DWORK(KTI), N, DWORK(KW), N, ZERO, G, LDG ) +C + CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KW), M ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NCR, N, ONE, + $ DWORK(KW), M, DWORK(KT), N, ZERO, F, LDF ) +C +C Form the reduced controller state matrix, +C Ac = Ar + Br*Fr + Gr*Cr + Gr*D*Fr = Ar + Br*Fr + Gr*(Cr+D*Fr) . +C +C Workspace: need P*N. +C + CALL DLACPY( 'Full', P, NCR, C, LDC, DWORK, P ) + IF( WITHD) CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NCR, M, + $ ONE, D, LDD, F, LDF, ONE, DWORK, P ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, P, ONE, G, + $ LDG, DWORK, P, ONE, A, LDA ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', NCR, NCR, M, ONE, B, + $ LDB, F, LDF, ONE, A, LDA ) +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB16CD *** + END diff --git a/mex/sources/libslicot/SB16CY.f b/mex/sources/libslicot/SB16CY.f new file mode 100644 index 000000000..34ebaae79 --- /dev/null +++ b/mex/sources/libslicot/SB16CY.f @@ -0,0 +1,409 @@ + SUBROUTINE SB16CY( DICO, JOBCF, N, M, P, A, LDA, B, LDB, C, LDC, + $ F, LDF, G, LDG, SCALEC, SCALEO, S, LDS, R, LDR, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute, for a given open-loop model (A,B,C,0), and for +C given state feedback gain F and full observer gain G, +C such that A+B*F and A+G*C are stable, the Cholesky factors +C Su and Ru of a controllability Grammian P = Su*Su' and of +C an observability Grammian Q = Ru'*Ru corresponding to a +C frequency-weighted model reduction of the left or right coprime +C factors of the state-feedback controller. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the open-loop system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C JOBCF CHARACTER*1 +C Specifies whether a left or right coprime factorization +C of the state-feedback controller is to be used as follows: +C = 'L': use a left coprime factorization; +C = 'R': use a right coprime factorization. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the open-loop state-space representation, +C i.e., the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the open-loop system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input/state matrix B of the open-loop system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C state/output matrix C of the open-loop system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C F (input) DOUBLE PRECISION array, dimension (LDF,N) +C The leading M-by-N part of this array must contain a +C stabilizing state feedback matrix. +C +C LDF INTEGER +C The leading dimension of array F. LDF >= MAX(1,M). +C +C G (input) DOUBLE PRECISION array, dimension (LDG,P) +C The leading N-by-P part of this array must contain a +C stabilizing observer gain matrix. +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,N). +C +C SCALEC (output) DOUBLE PRECISION +C Scaling factor for the controllability Grammian. +C See METHOD. +C +C SCALEO (output) DOUBLE PRECISION +C Scaling factor for the observability Grammian. +C See METHOD. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor Su of frequency-weighted +C cotrollability Grammian P = Su*Su'. See METHOD. +C +C LDS INTEGER +C The leading dimension of the array S. LDS >= MAX(1,N). +C +C R (output) DOUBLE PRECISION array, dimension (LDR,N) +C The leading N-by-N upper triangular part of this array +C contains the Cholesky factor Ru of the frequency-weighted +C observability Grammian Q = Ru'*Ru. See METHOD. +C +C LDR INTEGER +C The leading dimension of the array R. LDR >= MAX(1,N). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*(N + MAX(N,M) + MIN(N,M) + 6)), +C if JOBCF = 'L'; +C LDWORK >= MAX(1, N*(N + MAX(N,P) + MIN(N,P) + 6)), +C if JOBCF = 'R'. +C For optimum performance LDWORK should be larger. +C An upper bound for both cases is +C LDWORK >= MAX(1, N*(N + MAX(N,M,P) + 7)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: eigenvalue computation failure; +C = 2: the matrix A+G*C is not stable; +C = 3: the matrix A+B*F is not stable; +C = 4: the Lyapunov equation for computing the +C observability Grammian is (nearly) singular; +C = 5: the Lyapunov equation for computing the +C controllability Grammian is (nearly) singular. +C +C METHOD +C +C In accordance with the type of the coprime factorization +C of the controller (left or right), the Cholesky factors Su and Ru +C of the frequency-weighted controllability Grammian P = Su*Su' and +C of the frequency-weighted observability Grammian Q = Ru'*Ru are +C computed by solving appropriate Lyapunov or Stein equations [1]. +C +C If JOBCF = 'L' and DICO = 'C', P and Q are computed as the +C solutions of the following Lyapunov equations: +C +C (A+B*F)*P + P*(A+B*F)' + scalec^2*B*B' = 0, (1) +C +C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*F'*F = 0. (2) +C +C If JOBCF = 'L' and DICO = 'D', P and Q are computed as the +C solutions of the following Stein equations: +C +C (A+B*F)*P*(A+B*F)' - P + scalec^2*B*B' = 0, (3) +C +C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*F'*F = 0. (4) +C +C If JOBCF = 'R' and DICO = 'C', P and Q are computed as the +C solutions of the following Lyapunov equations: +C +C (A+B*F)*P + P*(A+B*F)' + scalec^2*G*G' = 0, (5) +C +C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*C'*C = 0. (6) +C +C If JOBCF = 'R' and DICO = 'D', P and Q are computed as the +C solutions of the following Stein equations: +C +C (A+B*F)*P*(A+B*F)' - P + scalec^2*G*G' = 0, (7) +C +C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*C'*C = 0. (8) +C +C REFERENCES +C +C [1] Liu, Y., Anderson, B.D.O. and Ly, O.L. +C Coprime factorization controller reduction with Bezout +C identity induced frequency weighting. +C Automatica, vol. 26, pp. 233-249, 1990. +C +C CONTRIBUTORS +C +C A. Varga, German Aerospace Center, Oberpfaffenhofen, October 2000. +C D. Sima, University of Bucharest, October 2000. +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2000. +C +C REVISIONS +C +C A. Varga, Australian National University, Canberra, November 2000. +C +C KEYWORDS +C +C Controller reduction, frequency weighting, multivariable system, +C state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBCF + INTEGER INFO, LDA, LDB, LDC, LDF, LDG, LDR, LDS, LDWORK, + $ M, N, P + DOUBLE PRECISION SCALEC, SCALEO +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), + $ F(LDF,*), G(LDG,*), R(LDR,*), S(LDS,*) +C .. Local Scalars .. + LOGICAL DISCR, LEFTW + INTEGER IERR, KAW, KU, KW, KWI, KWR, LDU, LW, ME, MP, + $ WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, SB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + DISCR = LSAME( DICO, 'D' ) + LEFTW = LSAME( JOBCF, 'L' ) +C + INFO = 0 + IF( LEFTW ) THEN + MP = M + ELSE + MP = P + END IF + LW = N*( N + MAX( N, MP ) + MIN( N, MP ) + 6 ) +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LEFTW .OR. LSAME( JOBCF, 'R' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -13 + ELSE IF( LDG.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDS.LT.MAX( 1, N ) ) THEN + INFO = -19 + ELSE IF( LDR.LT.MAX( 1, N ) ) THEN + INFO = -21 + ELSE IF( LDWORK.LT.MAX( 1, LW ) ) THEN + INFO = -23 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SB16CY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( N, M, P ).EQ.0 ) THEN + SCALEC = ONE + SCALEO = ONE + DWORK(1) = ONE + RETURN + END IF +C +C Allocate storage for work arrays. +C + KAW = 1 + KU = KAW + N*N + KWR = KU + N*MAX( N, MP ) + KWI = KWR + N + KW = KWI + N +C +C Form A+G*C. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) + CALL DGEMM( 'No-transpose', 'No-transpose', N, N, P, ONE, + $ G, LDG, C, LDC, ONE, DWORK(KAW), N ) +C +C Form the factor H of the free term. +C + IF( LEFTW ) THEN +C +C H = F. +C + LDU = MAX( N, M ) + ME = M + CALL DLACPY( 'Full', M, N, F, LDF, DWORK(KU), LDU ) + ELSE +C +C H = C. +C + LDU = MAX( N, P ) + ME = P + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KU), LDU ) + END IF +C +C Solve for the Cholesky factor Ru of Q, Q = Ru'*Ru, +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C (A+G*C)'*Q + Q*(A+G*C) + scaleo^2*H'*H = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C (A+G*C)'*Q*(A+G*C) - Q + scaleo^2*H'*H = 0. +C +C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; +C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. +C prefer larger. +C + CALL SB03OD( DICO, 'NoFact', 'NoTransp', N, ME, DWORK(KAW), N, + $ R, LDR, DWORK(KU), LDU, SCALEO, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.2 ) THEN + INFO = 2 + ELSE IF( IERR.EQ.1 ) THEN + INFO = 4 + ELSE IF( IERR.EQ.6 ) THEN + INFO = 1 + END IF + RETURN + END IF +C + WRKOPT = INT( DWORK(KW) ) + KW - 1 + CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, R, LDR ) +C +C Form A+B*F. +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KAW), N ) + CALL DGEMM( 'No-transpose', 'No-transpose', N, N, M, ONE, + $ B, LDB, F, LDF, ONE, DWORK(KAW), N ) +C +C Form the factor K of the free term. +C + LDU = N + IF( LEFTW ) THEN +C +C K = B. +C + ME = M + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KU), LDU ) + ELSE +C +C K = G. +C + ME = P + CALL DLACPY( 'Full', N, P, G, LDG, DWORK(KU), LDU ) + END IF +C +C Solve for the Cholesky factor Su of P, P = Su*Su', +C the continuous-time Lyapunov equation (if DICO = 'C') +C +C (A+B*F)*P + P*(A+B*F)' + scalec^2*K*K' = 0, +C +C or the discrete-time Lyapunov equation (if DICO = 'D') +C +C (A+B*F)*P*(A+B*F)' - P + scalec^2*K*K' = 0. +C +C Workspace: need N*(N + MAX(N,M) + MIN(N,M) + 6) if JOBCF = 'L'; +C N*(N + MAX(N,P) + MIN(N,P) + 6) if JOBCF = 'R'. +C prefer larger. +C + CALL SB03OD( DICO, 'NoFact', 'Transp', N, ME, DWORK(KAW), N, + $ S, LDS, DWORK(KU), LDU, SCALEC, DWORK(KWR), + $ DWORK(KWI), DWORK(KW), LDWORK-KW+1, IERR ) + IF( IERR.NE.0 ) THEN + IF( IERR.EQ.2 ) THEN + INFO = 3 + ELSE IF( IERR.EQ.1 ) THEN + INFO = 5 + ELSE IF( IERR.EQ.6 ) THEN + INFO = 1 + END IF + RETURN + END IF + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + CALL DLACPY( 'Upper', N, N, DWORK(KU), LDU, S, LDS ) +C +C Save the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of SB16CY *** + END diff --git a/mex/sources/libslicot/SG02AD.f b/mex/sources/libslicot/SG02AD.f new file mode 100644 index 000000000..e7a9d9782 --- /dev/null +++ b/mex/sources/libslicot/SG02AD.f @@ -0,0 +1,939 @@ + SUBROUTINE SG02AD( DICO, JOBB, FACT, UPLO, JOBL, SCAL, SORT, ACC, + $ N, M, P, A, LDA, E, LDE, B, LDB, Q, LDQ, R, + $ LDR, L, LDL, RCONDU, X, LDX, ALFAR, ALFAI, + $ BETA, S, LDS, T, LDT, U, LDU, TOL, IWORK, + $ DWORK, LDWORK, BWORK, IWARN, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the continuous-time algebraic Riccati +C equation +C -1 +C Q + A'XE + E'XA - (L+E'XB)R (L+E'XB)' = 0 , (1) +C +C or the discrete-time algebraic Riccati equation +C -1 +C E'XE = A'XA - (L+A'XB)(R + B'XB) (L+A'XB)' + Q , (2) +C +C where A, E, B, Q, R, and L are N-by-N, N-by-N, N-by-M, N-by-N, +C M-by-M and N-by-M matrices, respectively, such that Q = C'C, +C R = D'D and L = C'D; X is an N-by-N symmetric matrix. +C The routine also returns the computed values of the closed-loop +C spectrum of the system, i.e., the stable eigenvalues +C lambda(1),...,lambda(N) of the pencil (A - BF,E), where F is +C the optimal gain matrix, +C -1 +C F = R (L+E'XB)' , for (1), +C +C and +C -1 +C F = (R+B'XB) (L+A'XB)' , for (2). +C -1 +C Optionally, matrix G = BR B' may be given instead of B and R. +C Other options include the case with Q and/or R given in a +C factored form, Q = C'C, R = D'D, and with L a zero matrix. +C +C The routine uses the method of deflating subspaces, based on +C reordering the eigenvalues in a generalized Schur matrix pair. +C +C It is assumed that E is nonsingular, but this condition is not +C checked. Note that the definition (1) of the continuous-time +C algebraic Riccati equation, and the formula for the corresponding +C optimal gain matrix, require R to be nonsingular, but the +C associated linear quadratic optimal problem could have a unique +C solution even when matrix R is singular, under mild assumptions +C (see METHOD). The routine SG02AD works accordingly in this case. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of Riccati equation to be solved as +C follows: +C = 'C': Equation (1), continuous-time case; +C = 'D': Equation (2), discrete-time case. +C +C JOBB CHARACTER*1 +C Specifies whether or not the matrix G is given, instead +C of the matrices B and R, as follows: +C = 'B': B and R are given; +C = 'G': G is given. +C +C FACT CHARACTER*1 +C Specifies whether or not the matrices Q and/or R (if +C JOBB = 'B') are factored, as follows: +C = 'N': Not factored, Q and R are given; +C = 'C': C is given, and Q = C'C; +C = 'D': D is given, and R = D'D; +C = 'B': Both factors C and D are given, Q = C'C, R = D'D. +C +C UPLO CHARACTER*1 +C If JOBB = 'G', or FACT = 'N', specifies which triangle of +C the matrices G, or Q and R, is stored, as follows: +C = 'U': Upper triangle is stored; +C = 'L': Lower triangle is stored. +C +C JOBL CHARACTER*1 +C Specifies whether or not the matrix L is zero, as follows: +C = 'Z': L is zero; +C = 'N': L is nonzero. +C JOBL is not used if JOBB = 'G' and JOBL = 'Z' is assumed. +C SLICOT Library routine SB02MT should be called just before +C SG02AD, for obtaining the results when JOBB = 'G' and +C JOBL = 'N'. +C +C SCAL CHARACTER*1 +C If JOBB = 'B', specifies whether or not a scaling strategy +C should be used to scale Q, R, and L, as follows: +C = 'G': General scaling should be used; +C = 'N': No scaling should be used. +C SCAL is not used if JOBB = 'G'. +C +C SORT CHARACTER*1 +C Specifies which eigenvalues should be obtained in the top +C of the generalized Schur form, as follows: +C = 'S': Stable eigenvalues come first; +C = 'U': Unstable eigenvalues come first. +C +C ACC CHARACTER*1 +C Specifies whether or not iterative refinement should be +C used to solve the system of algebraic equations giving +C the solution matrix X, as follows: +C = 'R': Use iterative refinement; +C = 'N': Do not use iterative refinement. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e., the order of the +C matrices A, E, Q, and X, and the number of rows of the +C matrices B and L. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. If JOBB = 'B', M is the +C order of the matrix R, and the number of columns of the +C matrix B. M >= 0. +C M is not used if JOBB = 'G'. +C +C P (input) INTEGER +C The number of system outputs. If FACT = 'C' or 'D' or 'B', +C P is the number of rows of the matrices C and/or D. +C P >= 0. +C Otherwise, P is not used. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the descriptor system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N part of this array must contain the +C matrix E of the descriptor system. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,*) +C If JOBB = 'B', the leading N-by-M part of this array must +C contain the input matrix B of the system. +C If JOBB = 'G', the leading N-by-N upper triangular part +C (if UPLO = 'U') or lower triangular part (if UPLO = 'L') +C of this array must contain the upper triangular part or +C lower triangular part, respectively, of the matrix +C -1 +C G = BR B'. The 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 FACT = 'C' or 'B', the leading P-by-N part of this +C array must contain the output matrix C of the system. +C If JOBB = 'B' and SCAL = 'G', then Q is modified +C internally, but is restored on exit. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= MAX(1,N) if FACT = 'N' or 'D'; +C LDQ >= MAX(1,P) if FACT = 'C' or 'B'. +C +C R (input) DOUBLE PRECISION array, dimension (LDR,*) +C If FACT = 'N' or 'C', the leading M-by-M upper triangular +C part (if UPLO = 'U') or lower triangular part (if UPLO = +C 'L') of this array must contain the upper triangular part +C or lower triangular part, respectively, of the symmetric +C input weighting matrix R. The 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 = 'B' and SCAL = 'G', then R is modified +C internally, but is restored on exit. +C If JOBB = 'G', this array is not referenced. +C +C LDR INTEGER +C The leading dimension of array R. +C LDR >= MAX(1,M) if JOBB = 'B' and FACT = 'N' or 'C'; +C LDR >= MAX(1,P) if JOBB = 'B' and FACT = 'D' or 'B'; +C LDR >= 1 if JOBB = 'G'. +C +C L (input) DOUBLE PRECISION array, dimension (LDL,*) +C If JOBL = 'N' and JOBB = 'B', the leading N-by-M part of +C this array must contain the cross weighting matrix L. +C If JOBB = 'B' and SCAL = 'G', then L is modified +C internally, but is restored on exit. +C If JOBL = 'Z' or JOBB = 'G', this array is not referenced. +C +C LDL INTEGER +C The leading dimension of array L. +C LDL >= MAX(1,N) if JOBL = 'N' and JOBB = 'B'; +C LDL >= 1 if JOBL = 'Z' or JOBB = 'G'. +C +C RCONDU (output) DOUBLE PRECISION +C If N > 0 and INFO = 0 or INFO = 7, an estimate of the +C reciprocal of the condition number (in the 1-norm) of +C the N-th order system of algebraic equations from which +C the solution matrix X is obtained. +C +C X (output) DOUBLE PRECISION array, dimension (LDX,N) +C If INFO = 0, the leading N-by-N part of this array +C contains the solution matrix X of the problem. +C +C LDX INTEGER +C The leading dimension of array X. LDX >= MAX(1,N). +C +C ALFAR (output) DOUBLE PRECISION array, dimension (2*N) +C ALFAI (output) DOUBLE PRECISION array, dimension (2*N) +C BETA (output) DOUBLE PRECISION array, dimension (2*N) +C The generalized eigenvalues of the 2N-by-2N matrix pair, +C ordered as specified by SORT (if INFO = 0, or INFO >= 5). +C For instance, if SORT = 'S', the leading N elements of +C these arrays contain the closed-loop spectrum of the +C system. Specifically, +C lambda(k) = [ALFAR(k)+j*ALFAI(k)]/BETA(k) for +C k = 1,2,...,N. +C +C S (output) DOUBLE PRECISION array, dimension (LDS,*) +C The leading 2N-by-2N part of this array contains the +C ordered real Schur form S of the first matrix in the +C reduced matrix pencil associated to the optimal problem, +C corresponding to the scaled Q, R, and L, if JOBB = 'B' +C and SCAL = 'G'. That is, +C +C (S S ) +C ( 11 12) +C S = ( ), +C (0 S ) +C ( 22) +C +C where S , S and S are N-by-N matrices. +C 11 12 22 +C Array S must have 2*N+M columns if JOBB = 'B', and 2*N +C columns, otherwise. +C +C LDS INTEGER +C The leading dimension of array S. +C LDS >= MAX(1,2*N+M) if JOBB = 'B'; +C LDS >= MAX(1,2*N) if JOBB = 'G'. +C +C T (output) DOUBLE PRECISION array, dimension (LDT,2*N) +C The leading 2N-by-2N part of this array contains the +C ordered upper triangular form T of the second matrix in +C the reduced matrix pencil associated to the optimal +C problem, corresponding to the scaled Q, R, and L, if +C JOBB = 'B' and SCAL = 'G'. That is, +C +C (T T ) +C ( 11 12) +C T = ( ), +C (0 T ) +C ( 22) +C +C where T , T and T are N-by-N matrices. +C 11 12 22 +C +C LDT INTEGER +C The leading dimension of array T. +C LDT >= MAX(1,2*N+M) if JOBB = 'B'; +C LDT >= MAX(1,2*N) if JOBB = 'G'. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,2*N) +C The leading 2N-by-2N part of this array contains the right +C transformation matrix U which reduces the 2N-by-2N matrix +C pencil to the ordered generalized real Schur form (S,T). +C That is, +C +C (U U ) +C ( 11 12) +C U = ( ), +C (U U ) +C ( 21 22) +C +C where U , U , U and U are N-by-N matrices. +C 11 12 21 22 +C If JOBB = 'B' and SCAL = 'G', then U corresponds to the +C scaled pencil. If a basis for the stable deflating +C subspace of the original problem is needed, then the +C submatrix U must be multiplied by the scaling factor +C 21 +C contained in DWORK(4). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,2*N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used to test for near singularity of +C the original matrix pencil, specifically of the triangular +C M-by-M factor obtained during the reduction process. If +C the user sets TOL > 0, then the given value of TOL is used +C as a lower bound for the reciprocal condition number of +C that matrix; a matrix whose estimated condition number is +C less than 1/TOL is considered to be nonsingular. If the +C user sets TOL <= 0, then a default tolerance, defined by +C TOLDEF = EPS, is used instead, where EPS is the machine +C precision (see LAPACK Library routine DLAMCH). +C This parameter is not referenced if JOBB = 'G'. +C +C Workspace +C +C IWORK INTEGER array, dimension (LIWORK) +C LIWORK >= MAX(1,M,2*N) if JOBB = 'B'; +C LIWORK >= MAX(1,2*N) if JOBB = 'G'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. If JOBB = 'B' and N > 0, DWORK(2) returns the +C reciprocal of the condition number of the M-by-M bottom +C right lower triangular matrix obtained while compressing +C the matrix pencil of order 2N+M to obtain a pencil of +C order 2N. If ACC = 'R', and INFO = 0 or INFO = 7, DWORK(3) +C returns the reciprocal pivot growth factor (see SLICOT +C Library routine MB02PD) for the LU factorization of the +C coefficient matrix of the system of algebraic equations +C giving the solution matrix X; if DWORK(3) is much +C less than 1, then the computed X and RCONDU could be +C unreliable. If INFO = 0 or INFO = 7, DWORK(4) returns the +C scaling factor used to scale Q, R, and L. DWORK(4) is set +C to 1 if JOBB = 'G' or SCAL = 'N'. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(7*(2*N+1)+16,16*N), if JOBB = 'G'; +C LDWORK >= MAX(7*(2*N+1)+16,16*N,2*N+M,3*M), if JOBB = 'B'. +C For optimum performance LDWORK should be larger. +C +C BWORK LOGICAL array, dimension (2*N) +C +C Warning Indicator +C +C IWARN INTEGER +C = 0: no warning; +C = 1: the computed solution may be inaccurate due to poor +C scaling or eigenvalues too close to the boundary of +C the stability domain (the imaginary axis, if +C DICO = 'C', or the unit circle, if DICO = 'D'). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the computed extended matrix pencil is singular, +C possibly due to rounding errors; +C = 2: if the QZ algorithm failed; +C = 3: if reordering of the generalized eigenvalues failed; +C = 4: if after reordering, roundoff changed values of +C some complex eigenvalues so that leading eigenvalues +C in the generalized Schur form no longer satisfy the +C stability condition; this could also be caused due +C to scaling; +C = 5: if the computed dimension of the solution does not +C equal N; +C = 6: if the spectrum is too close to the boundary of +C the stability domain; +C = 7: if a singular matrix was encountered during the +C computation of the solution matrix X. +C +C METHOD +C +C The routine uses a variant of the method of deflating subspaces +C proposed by van Dooren [1]. See also [2], [3], [4]. +C It is assumed that E is nonsingular, the triple (E,A,B) is +C strongly stabilizable and detectable (see [3]); if, in addition, +C +C - [ Q L ] +C R := [ ] >= 0 , +C [ L' R ] +C +C then the pencils +C +C discrete-time continuous-time +C +C |A 0 B| |E 0 0| |A 0 B| |E 0 0| +C |Q -E' L| - z |0 -A' 0| , |Q A' L| - s |0 -E' 0| , (3) +C |L' 0 R| |0 -B' 0| |L' B' R| |0 0 0| +C +C are dichotomic, i.e., they have no eigenvalues on the boundary of +C the stability domain. The above conditions are sufficient for +C regularity of these pencils. A necessary condition is that +C rank([ B' L' R']') = m. +C +C Under these assumptions the algebraic Riccati equation is known to +C have a unique non-negative definite solution. +C The first step in the method of deflating subspaces is to form the +C extended matrices in (3), of order 2N + M. Next, these pencils are +C compressed to a form of order 2N (see [1]) +C +C lambda x A - B . +C f f +C +C This generalized eigenvalue problem is then solved using the QZ +C algorithm and the stable deflating subspace Ys is determined. +C If [Y1'|Y2']' is a basis for Ys, then the required solution is +C -1 +C X = Y2 x Y1 . +C +C REFERENCES +C +C [1] Van Dooren, P. +C A Generalized Eigenvalue Approach for Solving Riccati +C Equations. +C SIAM J. Sci. Stat. Comp., 2, pp. 121-135, 1981. +C +C [2] Arnold, III, W.F. and Laub, A.J. +C Generalized Eigenproblem Algorithms and Software for +C Algebraic Riccati Equations. +C Proc. IEEE, 72, 1746-1754, 1984. +C +C [3] Mehrmann, V. +C The Autonomous Linear Quadratic Control Problem. Theory and +C Numerical Solution. +C Lect. Notes in Control and Information Sciences, vol. 163, +C Springer-Verlag, Berlin, 1991. +C +C [4] Sima, V. +C Algorithms for Linear-Quadratic Optimization. +C Pure and Applied Mathematics: A Series of Monographs and +C Textbooks, vol. 200, Marcel Dekker, Inc., New York, 1996. +C +C NUMERICAL ASPECTS +C +C This routine is particularly suited for systems where the matrix R +C is ill-conditioned, or even singular. +C +C FURTHER COMMENTS +C +C To obtain a stabilizing solution of the algebraic Riccati +C equations set SORT = 'S'. +C +C The routine can also compute the anti-stabilizing solutions of +C the algebraic Riccati equations, by specifying SORT = 'U'. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, June 2002. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, September 2002, +C December 2002. +C +C KEYWORDS +C +C Algebraic Riccati equation, closed loop system, continuous-time +C system, discrete-time system, optimal regulator, Schur form. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, HALF, ONE, P1, FOUR + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, + $ P1 = 0.1D0, FOUR = 4.0D0 ) +C .. Scalar Arguments .. + CHARACTER ACC, DICO, FACT, JOBB, JOBL, SCAL, SORT, UPLO + INTEGER INFO, IWARN, LDA, LDB, LDE, LDL, LDQ, LDR, LDS, + $ LDT, LDU, LDWORK, LDX, M, N, P + DOUBLE PRECISION RCONDU, TOL +C .. Array Arguments .. + LOGICAL BWORK(*) + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), ALFAI(*), ALFAR(*), B(LDB,*), BETA(*), + $ DWORK(*), E(LDE,*), L(LDL,*), Q(LDQ,*), + $ R(LDR,*), S(LDS,*), T(LDT,*), U(LDU,*), X(LDX,*) +C .. Local Scalars .. + CHARACTER EQUED, QTYPE, RTYPE + LOGICAL COLEQU, DISCR, LFACB, LFACN, LFACQ, LFACR, + $ LJOBB, LJOBL, LJOBLN, LSCAL, LSORT, LUPLO, + $ REFINE, ROWEQU + INTEGER I, INFO1, IW, IWB, IWC, IWF, IWR, J, LDW, MP, + $ NDIM, NN, NNM, NP, NP1, WRKOPT + DOUBLE PRECISION ASYM, EPS, PIVOTU, RCONDL, RNORM, SCALE, SEPS, + $ U12M, UNORM +C .. External Functions .. + LOGICAL LSAME, SB02OU, SB02OV, SB02OW + DOUBLE PRECISION DLAMCH, DLANGE, DLANSY + EXTERNAL DLAMCH, DLANGE, DLANSY, LSAME, SB02OU, SB02OV, + $ SB02OW +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGECON, DGEMM, DGEQRF, DGGES, + $ DLACPY, DLASCL, DLASET, DORGQR, DSCAL, DSWAP, + $ MB01SD, MB02PD, MB02VD, SB02OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, INT, MAX, SQRT +C .. Executable Statements .. +C + IWARN = 0 + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LJOBB = LSAME( JOBB, 'B' ) + LFACN = LSAME( FACT, 'N' ) + LFACQ = LSAME( FACT, 'C' ) + LFACR = LSAME( FACT, 'D' ) + LFACB = LSAME( FACT, 'B' ) + LUPLO = LSAME( UPLO, 'U' ) + LSORT = LSAME( SORT, 'S' ) + REFINE = LSAME( ACC, 'R' ) + NN = 2*N + IF ( LJOBB ) THEN + LJOBL = LSAME( JOBL, 'Z' ) + LJOBLN = LSAME( JOBL, 'N' ) + LSCAL = LSAME( SCAL, 'G' ) + NNM = NN + M + LDW = MAX( NNM, 3*M ) + ELSE + LSCAL = .FALSE. + NNM = NN + LDW = 1 + END IF + NP1 = N + 1 +C +C Test the input scalar arguments. +C + IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LJOBB .AND. .NOT.LSAME( JOBB, 'G' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LFACQ .AND. .NOT.LFACR .AND. .NOT.LFACB + $ .AND. .NOT.LFACN ) THEN + INFO = -3 + ELSE IF( .NOT.LJOBB .OR. LFACN ) THEN + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) + $ INFO = -4 + END IF + IF( INFO.EQ.0 .AND. LJOBB ) THEN + IF( .NOT.LJOBL .AND. .NOT.LJOBLN ) THEN + INFO = -5 + ELSE IF( .NOT.LSCAL .AND. .NOT. LSAME( SCAL, 'N' ) ) THEN + INFO = -6 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( .NOT.LSORT .AND. .NOT.LSAME( SORT, 'U' ) ) THEN + INFO = -7 + ELSE IF( .NOT.REFINE .AND. .NOT.LSAME( ACC, 'N' ) ) THEN + INFO = -8 + ELSE IF( N.LT.0 ) THEN + INFO = -9 + ELSE IF( LJOBB ) THEN + IF( M.LT.0 ) + $ INFO = -10 + END IF + END IF + IF( INFO.EQ.0 .AND. .NOT.LFACN ) THEN + IF( P.LT.0 ) + $ INFO = -11 + END IF + IF( INFO.EQ.0 ) THEN + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( ( ( LFACN.OR.LFACR ) .AND. LDQ.LT.MAX( 1, N ) ) .OR. + $ ( ( LFACQ.OR.LFACB ) .AND. LDQ.LT.MAX( 1, P ) ) ) THEN + INFO = -19 + ELSE IF( LJOBB ) THEN + IF ( ( LFACN.OR.LFACQ ) .AND. LDR.LT.MAX( 1, M ) .OR. + $ ( LFACR.OR.LFACB ) .AND. LDR.LT.MAX( 1, P ) ) THEN + INFO = -21 + ELSE IF( ( LJOBLN .AND. LDL.LT.MAX( 1, N ) ) .OR. + $ ( LJOBL .AND. LDL.LT.1 ) ) THEN + INFO = -23 + END IF + ELSE + IF( LDR.LT.1 ) THEN + INFO = -21 + ELSE IF( LDL.LT.1 ) THEN + INFO = -23 + END IF + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -26 + ELSE IF( LDS.LT.MAX( 1, NNM ) ) THEN + INFO = -31 + ELSE IF( LDT.LT.MAX( 1, NNM ) ) THEN + INFO = -33 + ELSE IF( LDU.LT.MAX( 1, NN ) ) THEN + INFO = -35 + ELSE IF( LDWORK.LT.MAX( 14*N + 23, 16*N, LDW ) ) THEN + INFO = -39 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'SG02AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + DWORK(1) = FOUR + DWORK(4) = ONE + RETURN + END IF +C +C Start computations. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + LSCAL = LSCAL .AND. LJOBB + IF ( LSCAL ) THEN +C +C Scale the matrices Q, R (or G), and L so that +C norm(Q) + norm(R) + norm(L) = 1, +C using the 1-norm. If Q and/or R are factored, the norms of +C the factors are used. +C Workspace: need max(N,M), if FACT = 'N'; +C N, if FACT = 'D'; +C M, if FACT = 'C'. +C + IF ( LFACN .OR. LFACR ) THEN + SCALE = DLANSY( '1-norm', UPLO, N, Q, LDQ, DWORK ) + QTYPE = UPLO + NP = N + ELSE + SCALE = DLANGE( '1-norm', P, N, Q, LDQ, DWORK ) + QTYPE = 'G' + NP = P + END IF +C + IF ( LFACN .OR. LFACQ ) THEN + RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK ) + RTYPE = UPLO + MP = M + ELSE + RNORM = DLANGE( '1-norm', P, M, R, LDR, DWORK ) + RTYPE = 'G' + MP = P + END IF + SCALE = SCALE + RNORM +C + IF ( LJOBLN ) + $ SCALE = SCALE + DLANGE( '1-norm', N, M, L, LDL, DWORK ) + IF ( SCALE.EQ.ZERO ) + $ SCALE = ONE +C + CALL DLASCL( QTYPE, 0, 0, SCALE, ONE, NP, N, Q, LDQ, INFO1 ) + CALL DLASCL( RTYPE, 0, 0, SCALE, ONE, MP, M, R, LDR, INFO1 ) + IF ( LJOBLN ) + $ CALL DLASCL( 'G', 0, 0, SCALE, ONE, N, M, L, LDL, INFO1 ) + ELSE + SCALE = ONE + END IF +C +C Construct the extended matrix pair. +C Workspace: need 1, if JOBB = 'G', +C max(1,2*N+M,3*M), if JOBB = 'B'; +C prefer larger. +C + CALL SB02OY( 'Optimal control', DICO, JOBB, FACT, UPLO, JOBL, + $ 'Not identity E', N, M, P, A, LDA, B, LDB, Q, LDQ, R, + $ LDR, L, LDL, E, LDE, S, LDS, T, LDT, TOL, IWORK, + $ DWORK, LDWORK, INFO ) +C + IF ( LSCAL ) THEN +C +C Undo scaling of the data arrays. +C + CALL DLASCL( QTYPE, 0, 0, ONE, SCALE, NP, N, Q, LDQ, INFO1 ) + CALL DLASCL( RTYPE, 0, 0, ONE, SCALE, MP, M, R, LDR, INFO1 ) + IF ( LJOBLN ) + $ CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, M, L, LDL, INFO1 ) + END IF +C + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = DWORK(1) + IF ( LJOBB ) + $ RCONDL = DWORK(2) +C +C Workspace: need max(7*(2*N+1)+16,16*N); +C prefer larger. +C + IF ( DISCR ) THEN + IF ( LSORT ) THEN +C +C The natural tendency of the QZ algorithm to get the largest +C eigenvalues in the leading part of the matrix pair is +C exploited, by computing the unstable eigenvalues of the +C permuted matrix pair. +C + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, T, + $ LDT, S, LDS, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + CALL DSWAP( N, ALFAR(NP1), 1, ALFAR, 1 ) + CALL DSWAP( N, ALFAI(NP1), 1, ALFAI, 1 ) + CALL DSWAP( N, BETA (NP1), 1, BETA , 1 ) + ELSE + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OV, NN, S, + $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + END IF + ELSE + IF ( LSORT ) THEN + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OW, NN, S, + $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + ELSE + CALL DGGES( 'No vectors', 'Vectors', 'Sort', SB02OU, NN, S, + $ LDS, T, LDT, NDIM, ALFAR, ALFAI, BETA, U, LDU, + $ U, LDU, DWORK, LDWORK, BWORK, INFO1 ) + END IF + END IF + IF ( INFO1.GT.0 .AND. INFO1.LE.NN+1 ) THEN + INFO = 2 + ELSE IF ( INFO1.EQ.NN+2 ) THEN + INFO = 4 + ELSE IF ( INFO1.EQ.NN+3 ) THEN + INFO = 3 + ELSE IF ( NDIM.NE.N ) THEN + INFO = 5 + END IF + IF ( INFO.NE.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Take the non-identity matrix E into account and orthogonalize the +C basis. Use the array X as workspace. +C Workspace: need N; +C prefer N*NB. +C + CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, E, LDE, + $ U, LDU, ZERO, X, LDX ) + CALL DLACPY( 'Full', N, N, X, LDX, U, LDU ) + CALL DGEQRF( NN, N, U, LDU, X, DWORK, LDWORK, INFO1 ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + CALL DORGQR( NN, N, N, U, LDU, X, DWORK, LDWORK, INFO1 ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Check for the symmetry of the solution. The array X is again used +C as workspace. +C + CALL DGEMM( 'Transpose', 'No transpose', N, N, N, ONE, U, LDU, + $ U(NP1,1), LDU, ZERO, X, LDX ) + U12M = ZERO + ASYM = ZERO +C + DO 20 J = 1, N +C + DO 10 I = 1, N + U12M = MAX( U12M, ABS( X(I,J) ) ) + ASYM = MAX( ASYM, ABS( X(I,J) - X(J,I) ) ) + 10 CONTINUE +C + 20 CONTINUE +C + EPS = DLAMCH( 'Epsilon' ) + SEPS = SQRT( EPS ) + ASYM = ASYM - SEPS + IF ( ASYM.GT.P1*U12M ) THEN + INFO = 6 + RETURN + ELSE IF ( ASYM.GT.SEPS ) THEN + IWARN = 1 + END IF +C +C Compute the solution of X*U(1,1) = U(2,1). Use the (2,1) block +C of S as a workspace for factoring U(1,1). +C + IF ( REFINE ) THEN +C +C Use LU factorization and iterative refinement for finding X. +C Workspace: need 8*N. +C +C First transpose U(2,1) in-situ. +C + DO 30 I = 1, N - 1 + CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) + 30 CONTINUE +C + IWR = 1 + IWC = IWR + N + IWF = IWC + N + IWB = IWF + N + IW = IWB + N +C + CALL MB02PD( 'Equilibrate', 'Transpose', N, N, U, LDU, + $ S(NP1,1), LDS, IWORK, EQUED, DWORK(IWR), + $ DWORK(IWC), U(NP1,1), LDU, X, LDX, RCONDU, + $ DWORK(IWF), DWORK(IWB), IWORK(NP1), DWORK(IW), + $ INFO1 ) +C +C Transpose U(2,1) back in-situ. +C + DO 40 I = 1, N - 1 + CALL DSWAP( N-I, U(N+I,I+1), LDU, U(N+I+1,I), 1 ) + 40 CONTINUE +C + IF( .NOT.LSAME( EQUED, 'N' ) ) THEN +C +C Undo the equilibration of U(1,1) and U(2,1). +C + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +C + IF( ROWEQU ) THEN +C + DO 50 I = 0, N - 1 + DWORK(IWR+I) = ONE / DWORK(IWR+I) + 50 CONTINUE +C + CALL MB01SD( 'Row scaling', N, N, U, LDU, DWORK(IWR), + $ DWORK(IWC) ) + END IF +C + IF( COLEQU ) THEN +C + DO 60 I = 0, N - 1 + DWORK(IWC+I) = ONE / DWORK(IWC+I) + 60 CONTINUE +C + CALL MB01SD( 'Column scaling', NN, N, U, LDU, DWORK(IWR), + $ DWORK(IWC) ) + END IF + END IF +C + PIVOTU = DWORK(IW) +C + IF ( INFO1.GT.0 ) THEN +C +C Singular matrix. Set INFO and DWORK for error return. +C + INFO = 7 + GO TO 80 + END IF +C + ELSE +C +C Use LU factorization and a standard solution algorithm. +C + CALL DLACPY( 'Full', N, N, U, LDU, S(NP1,1), LDS ) + CALL DLACPY( 'Full', N, N, U(NP1,1), LDU, X, LDX ) +C +C Solve the system X*U(1,1) = U(2,1). +C + CALL MB02VD( 'No Transpose', N, N, S(NP1,1), LDS, IWORK, X, + $ LDX, INFO1 ) +C + IF ( INFO1.NE.0 ) THEN + INFO = 7 + RCONDU = ZERO + GO TO 80 + ELSE +C +C Compute the norm of U(1,1). +C + UNORM = DLANGE( '1-norm', N, N, U, LDU, DWORK ) +C +C Estimate the reciprocal condition of U(1,1). +C Workspace: need 4*N. +C + CALL DGECON( '1-norm', N, S(NP1,1), LDS, UNORM, RCONDU, + $ DWORK, IWORK(NP1), INFO ) +C + IF ( RCONDU.LT.EPS ) THEN +C +C Nearly singular matrix. Set IWARN for warning indication. +C + IWARN = 1 + END IF + WRKOPT = MAX( WRKOPT, 4*N ) + END IF + END IF +C +C Set S(2,1) to zero. +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, S(NP1,1), LDS ) +C +C Make sure the solution matrix X is symmetric. +C + DO 70 I = 1, N - 1 + CALL DAXPY( N-I, ONE, X(I,I+1), LDX, X(I+1,I), 1 ) + CALL DSCAL( N-I, HALF, X(I+1,I), 1 ) + CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) + 70 CONTINUE +C + IF ( LSCAL ) THEN +C +C Undo scaling for the solution X. +C + CALL DLASCL( 'G', 0, 0, ONE, SCALE, N, N, X, LDX, INFO1 ) + END IF +C + DWORK(1) = WRKOPT +C + 80 CONTINUE + IF ( LJOBB ) + $ DWORK(2) = RCONDL + IF ( REFINE ) + $ DWORK(3) = PIVOTU + DWORK(4) = SCALE +C + RETURN +C *** Last line of SG02AD *** + END diff --git a/mex/sources/libslicot/SG03AD.f b/mex/sources/libslicot/SG03AD.f new file mode 100644 index 000000000..a08e218ca --- /dev/null +++ b/mex/sources/libslicot/SG03AD.f @@ -0,0 +1,639 @@ + SUBROUTINE SG03AD( DICO, JOB, FACT, TRANS, UPLO, N, A, LDA, E, + $ LDE, Q, LDQ, Z, LDZ, X, LDX, SCALE, SEP, FERR, + $ ALPHAR, ALPHAI, BETA, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the generalized continuous-time Lyapunov +C equation +C +C T T +C op(A) X op(E) + op(E) X op(A) = SCALE * Y, (1) +C +C or the generalized discrete-time Lyapunov equation +C +C T T +C op(A) X op(A) - op(E) X op(E) = SCALE * Y, (2) +C +C where op(M) is either M or M**T for M = A, E and the right hand +C side Y is symmetric. A, E, Y, and the solution X are N-by-N +C matrices. SCALE is an output scale factor, set to avoid overflow +C in X. +C +C Estimates of the separation and the relative forward error norm +C are provided. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies which type of the equation is considered: +C = 'C': Continuous-time equation (1); +C = 'D': Discrete-time equation (2). +C +C JOB CHARACTER*1 +C Specifies if the solution is to be computed and if the +C separation is to be estimated: +C = 'X': Compute the solution only; +C = 'S': Estimate the separation only; +C = 'B': Compute the solution and estimate the separation. +C +C FACT CHARACTER*1 +C Specifies whether the generalized real Schur +C factorization of the pencil A - lambda * E is supplied +C on entry or not: +C = 'N': Factorization is not supplied; +C = 'F': Factorization is supplied. +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': op(A) = A, op(E) = E; +C = 'T': op(A) = A**T, op(E) = E**T. +C +C UPLO CHARACTER*1 +C Specifies whether the lower or the upper triangle of the +C array X is needed on input: +C = 'L': Only the lower triangle is needed on input; +C = 'U': Only the upper triangle is needed on input. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C Hessenberg part of this array must contain the +C generalized Schur factor A_s of the matrix A (see +C definition (3) in section METHOD). A_s must be an upper +C quasitriangular matrix. The elements below the upper +C Hessenberg part of the array A are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor A_s of the matrix A. (A_s is +C an upper quasitriangular matrix.) +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C triangular part of this array must contain the +C generalized Schur factor E_s of the matrix E (see +C definition (4) in section METHOD). The elements below the +C upper triangular part of the array E are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the coefficient matrix E of the +C equation. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor E_s of the matrix E. (E_s is +C an upper triangular matrix.) +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Q from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Q need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Q from the generalized Schur +C factorization. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Z from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Z need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Z from the generalized Schur +C factorization. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, if JOB = 'B' or 'X', then the leading N-by-N +C part of this array must contain the right hand side matrix +C Y of the equation. Either the lower or the upper +C triangular part of this array is needed (see mode +C parameter UPLO). +C If JOB = 'S', X is not referenced. +C On exit, if JOB = 'B' or 'X', and INFO = 0, 3, or 4, then +C the leading N-by-N part of this array contains the +C solution matrix X of the equation. +C If JOB = 'S', X is not referenced. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C (0 < SCALE <= 1) +C +C SEP (output) DOUBLE PRECISION +C If JOB = 'S' or JOB = 'B', and INFO = 0, 3, or 4, then +C SEP contains an estimate of the separation of the +C Lyapunov operator. +C +C FERR (output) DOUBLE PRECISION +C If JOB = 'B', and INFO = 0, 3, or 4, then FERR contains an +C estimated forward error bound for the solution X. If XTRUE +C is the true solution, FERR estimates the relative error +C in the computed solution, measured in the Frobenius norm: +C norm(X - XTRUE) / norm(XTRUE) +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C If FACT = 'N' and INFO = 0, 3, or 4, then +C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the +C eigenvalues of the matrix pencil A - lambda * E. +C If FACT = 'F', ALPHAR, ALPHAI, and BETA are not +C referenced. +C +C Workspace +C +C IWORK INTEGER array, dimension (N**2) +C IWORK is not referenced if JOB = 'X'. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. The following table +C contains the minimal work space requirements depending +C on the choice of JOB and FACT. +C +C JOB FACT | LDWORK +C -------------------+------------------- +C 'X' 'F' | MAX(1,N) +C 'X' 'N' | MAX(1,4*N) +C 'B', 'S' 'F' | MAX(1,2*N**2) +C 'B', 'S' 'N' | MAX(1,2*N**2,4*N) +C +C For optimum performance, LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: FACT = 'F' and the matrix contained in the upper +C Hessenberg part of the array A is not in upper +C quasitriangular form; +C = 2: FACT = 'N' and the pencil A - lambda * E cannot be +C reduced to generalized Schur form: LAPACK routine +C DGEGS has failed to converge; +C = 3: DICO = 'D' and the pencil A - lambda * E has a +C pair of reciprocal eigenvalues. That is, lambda_i = +C 1/lambda_j for some i and j, where lambda_i and +C lambda_j are eigenvalues of A - lambda * E. Hence, +C equation (2) is singular; perturbed values were +C used to solve the equation (but the matrices A and +C E are unchanged); +C = 4: DICO = 'C' and the pencil A - lambda * E has a +C degenerate pair of eigenvalues. That is, lambda_i = +C -lambda_j for some i and j, where lambda_i and +C lambda_j are eigenvalues of A - lambda * E. Hence, +C equation (1) is singular; perturbed values were +C used to solve the equation (but the matrices A and +C E are unchanged). +C +C METHOD +C +C A straightforward generalization [3] of the method proposed by +C Bartels and Stewart [1] is utilized to solve (1) or (2). +C +C First the pencil A - lambda * E is reduced to real generalized +C Schur form A_s - lambda * E_s by means of orthogonal +C transformations (QZ-algorithm): +C +C A_s = Q**T * A * Z (upper quasitriangular) (3) +C +C E_s = Q**T * E * Z (upper triangular). (4) +C +C If FACT = 'F', this step is omitted. Assuming SCALE = 1 and +C defining +C +C ( Z**T * Y * Z : TRANS = 'N' +C Y_s = < +C ( Q**T * Y * Q : TRANS = 'T' +C +C +C ( Q**T * X * Q if TRANS = 'N' +C X_s = < (5) +C ( Z**T * X * Z if TRANS = 'T' +C +C leads to the reduced Lyapunov equation +C +C T T +C op(A_s) X_s op(E_s) + op(E_s) X_s op(A_s) = Y_s, (6) +C +C or +C T T +C op(A_s) X_s op(A_s) - op(E_s) X_s op(E_s) = Y_s, (7) +C +C which are equivalent to (1) or (2), respectively. The solution X_s +C of (6) or (7) is computed via block back substitution (if TRANS = +C 'N') or block forward substitution (if TRANS = 'T'), where the +C block order is at most 2. (See [1] and [3] for details.) +C Equation (5) yields the solution matrix X. +C +C For fast computation the estimates of the separation and the +C forward error are gained from (6) or (7) rather than (1) or +C (2), respectively. We consider (6) and (7) as special cases of the +C generalized Sylvester equation +C +C R * X * S + U * X * V = Y, (8) +C +C whose separation is defined as follows +C +C sep = sep(R,S,U,V) = min || R * X * S + U * X * V || . +C ||X|| = 1 F +C F +C +C Equation (8) is equivalent to the system of linear equations +C +C K * vec(X) = (kron(S**T,R) + kron(V**T,U)) * vec(X) = vec(Y), +C +C where kron is the Kronecker product of two matrices and vec +C is the mapping that stacks the columns of a matrix. If K is +C nonsingular then +C +C sep = 1 / ||K**(-1)|| . +C 2 +C +C We estimate ||K**(-1)|| by a method devised by Higham [2]. Note +C that this method yields an estimation for the 1-norm but we use it +C as an approximation for the 2-norm. Estimates for the forward +C error norm are provided by +C +C FERR = 2 * EPS * ||A_s|| * ||E_s|| / sep +C F F +C +C in the continuous-time case (1) and +C +C FERR = EPS * ( ||A_s|| **2 + ||E_s|| **2 ) / sep +C F F +C +C in the discrete-time case (2). +C The reciprocal condition number, RCOND, of the Lyapunov equation +C can be estimated by FERR/EPS. +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Higham, N.J. +C FORTRAN codes for estimating the one-norm of a real or complex +C matrix, with applications to condition estimation. +C A.C.M. Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, 1988. +C +C [3] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The number of flops required by the routine is given by the +C following table. Note that we count a single floating point +C arithmetic operation as one flop. c is an integer number of modest +C size (say 4 or 5). +C +C | FACT = 'F' FACT = 'N' +C -----------+------------------------------------------ +C JOB = 'B' | (26+8*c)/3 * N**3 (224+8*c)/3 * N**3 +C JOB = 'S' | 8*c/3 * N**3 (198+8*c)/3 * N**3 +C JOB = 'X' | 26/3 * N**3 224/3 * N**3 +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if DICO = 'D' and the pencil A - lambda * E has a pair of almost +C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost +C degenerate pair of eigenvalues, then the Lyapunov equation will be +C ill-conditioned. Perturbed values were used to solve the equation. +C Ill-conditioning can be detected by a very small value of the +C reciprocal condition number RCOND. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, TWO, ZERO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER DICO, FACT, JOB, TRANS, UPLO + DOUBLE PRECISION FERR, SCALE, SEP + INTEGER INFO, LDA, LDE, LDQ, LDWORK, LDX, LDZ, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), BETA(*), + $ DWORK(*), E(LDE,*), Q(LDQ,*), X(LDX,*), + $ Z(LDZ,*) + INTEGER IWORK(*) +C .. Local Scalars .. + CHARACTER ETRANS + DOUBLE PRECISION EST, EPS, NORMA, NORME, SCALE1 + INTEGER I, INFO1, KASE, MINWRK, OPTWRK + LOGICAL ISDISC, ISFACT, ISTRAN, ISUPPR, WANTBH, WANTSP, + $ WANTX +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DNRM2 + LOGICAL LSAME + EXTERNAL DLAMCH, DNRM2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEGS, DLACON, MB01RD, MB01RW, SG03AX, + $ SG03AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. Executable Statements .. +C +C Decode input parameters. +C + ISDISC = LSAME( DICO, 'D' ) + WANTX = LSAME( JOB, 'X' ) + WANTSP = LSAME( JOB, 'S' ) + WANTBH = LSAME( JOB, 'B' ) + ISFACT = LSAME( FACT, 'F' ) + ISTRAN = LSAME( TRANS, 'T' ) + ISUPPR = LSAME( UPLO, 'U' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( WANTX .OR. WANTSP .OR. WANTBH ) ) THEN + INFO = -2 + ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN + INFO = -3 + ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -4 + ELSEIF ( .NOT.( ISUPPR .OR. LSAME( UPLO, 'L' ) ) ) THEN + INFO = -5 + ELSEIF ( N .LT. 0 ) THEN + INFO = -6 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -10 + ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN + INFO = -12 + ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN + INFO = -14 + ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN + INFO = -16 + ELSE + INFO = 0 + END IF + IF ( INFO .EQ. 0 ) THEN +C +C Compute minimal workspace. +C + IF ( WANTX ) THEN + IF ( ISFACT ) THEN + MINWRK = MAX( N, 1 ) + ELSE + MINWRK = MAX( 4*N, 1 ) + END IF + ELSE + IF ( ISFACT ) THEN + MINWRK = MAX( 2*N*N, 1 ) + ELSE + MINWRK = MAX( 2*N*N, 4*N, 1 ) + END IF + END IF + IF ( MINWRK .GT. LDWORK ) THEN + INFO = -25 + END IF + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) THEN + SCALE = ONE + IF ( .NOT.WANTX ) SEP = ZERO + IF ( WANTBH ) FERR = ZERO + DWORK(1) = ONE + RETURN + END IF +C + IF ( ISFACT ) THEN +C +C Make sure the upper Hessenberg part of A is quasitriangular. +C + DO 20 I = 1, N-2 + IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN + INFO = 1 + RETURN + END IF + 20 CONTINUE + END IF +C + IF ( .NOT.ISFACT ) THEN +C +C Reduce A - lambda * E to generalized Schur form. +C +C A := Q**T * A * Z (upper quasitriangular) +C E := Q**T * E * Z (upper triangular) +C +C ( Workspace: >= MAX(1,4*N) ) +C + CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR, + $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 2 + RETURN + END IF + OPTWRK = INT( DWORK(1) ) + ELSE + OPTWRK = MINWRK + END IF +C + IF ( WANTBH .OR. WANTX ) THEN +C +C Transform right hand side. +C +C X := Z**T * X * Z or X := Q**T * X * Q +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: >= N ) +C + IF ( LDWORK .LT. N*N ) THEN + IF ( ISTRAN ) THEN + CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Q, LDQ, + $ DWORK, INFO1 ) + ELSE + CALL MB01RW( UPLO, 'Transpose', N, N, X, LDX, Z, LDZ, + $ DWORK, INFO1 ) + END IF + ELSE + IF ( ISTRAN ) THEN + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, + $ Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) + ELSE + CALL MB01RD( UPLO, 'Transpose', N, N, ZERO, ONE, X, LDX, + $ Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) + END IF + END IF + IF ( .NOT.ISUPPR ) THEN + DO 40 I = 1, N-1 + CALL DCOPY( N-I, X(I+1,I), 1, X(I,I+1), LDX ) + 40 CONTINUE + END IF + OPTWRK = MAX( OPTWRK, N*N ) +C +C Solve reduced generalized Lyapunov equation. +C + IF ( ISDISC ) THEN + CALL SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) + IF ( INFO1 .NE. 0 ) + $ INFO = 3 + ELSE + CALL SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO1) + IF ( INFO1 .NE. 0 ) + $ INFO = 4 + END IF +C +C Transform the solution matrix back. +C +C X := Q * X * Q**T or X := Z * X * Z**T. +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: >= N ) +C + IF ( LDWORK .LT. N*N ) THEN + IF ( ISTRAN ) THEN + CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Z, + $ LDZ, DWORK, INFO1 ) + ELSE + CALL MB01RW( 'Upper', 'NoTranspose', N, N, X, LDX, Q, + $ LDQ, DWORK, INFO1 ) + END IF + ELSE + IF ( ISTRAN ) THEN + CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, + $ LDX, Z, LDZ, X, LDX, DWORK, LDWORK, INFO ) + ELSE + CALL MB01RD( 'Upper', 'NoTranspose', N, N, ZERO, ONE, X, + $ LDX, Q, LDQ, X, LDX, DWORK, LDWORK, INFO ) + END IF + END IF + DO 60 I = 1, N-1 + CALL DCOPY( N-I, X(I,I+1), LDX, X(I+1,I), 1 ) + 60 CONTINUE + END IF +C + IF ( WANTBH .OR. WANTSP ) THEN +C +C Estimate the 1-norm of the inverse Kronecker product matrix +C belonging to the reduced generalized Lyapunov equation. +C +C ( Workspace: 2*N*N ) +C + EST = ZERO + KASE = 0 + 80 CONTINUE + CALL DLACON( N*N, DWORK(N*N+1), DWORK, IWORK, EST, KASE ) + IF ( KASE .NE. 0 ) THEN + IF ( ( KASE.EQ.1 .AND. .NOT.ISTRAN ) .OR. + $ ( KASE.NE.1 .AND. ISTRAN ) ) THEN + ETRANS = 'N' + ELSE + ETRANS = 'T' + END IF + IF ( ISDISC ) THEN + CALL SG03AX( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 3 + ELSE + CALL SG03AY( ETRANS, N, A, LDA, E, LDE, DWORK, N, SCALE1, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 4 + END IF + GOTO 80 + END IF + SEP = SCALE1/EST + END IF +C +C Estimate the relative forward error. +C +C ( Workspace: 2*N ) +C + IF ( WANTBH ) THEN + EPS = DLAMCH( 'Precision' ) + DO 100 I = 1, N + DWORK(I) = DNRM2( MIN( I+1, N ), A(1,I), 1 ) + DWORK(N+I) = DNRM2( I, E(1,I), 1 ) + 100 CONTINUE + NORMA = DNRM2( N, DWORK, 1 ) + NORME = DNRM2( N, DWORK(N+1), 1 ) + IF ( ISDISC ) THEN + FERR = ( NORMA**2 + NORME**2 )*EPS/SEP + ELSE + FERR = TWO*NORMA*NORME*EPS/SEP + END IF + END IF +C + DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) + RETURN +C *** Last line of SG03AD *** + END diff --git a/mex/sources/libslicot/SG03AX.f b/mex/sources/libslicot/SG03AX.f new file mode 100644 index 000000000..872ed0282 --- /dev/null +++ b/mex/sources/libslicot/SG03AX.f @@ -0,0 +1,687 @@ + SUBROUTINE SG03AX( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the reduced generalized discrete-time +C Lyapunov equation +C +C T T +C A * X * A - E * X * E = SCALE * Y (1) +C +C or +C +C T T +C A * X * A - E * X * E = SCALE * Y (2) +C +C where the right hand side Y is symmetric. A, E, Y, and the +C solution X are N-by-N matrices. The pencil A - lambda * E must be +C in generalized Schur form (A upper quasitriangular, E upper +C triangular). SCALE is an output scale factor, set to avoid +C overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading N-by-N part of this array must +C contain the right hand side matrix Y of the equation. Only +C the upper triangular part of this matrix need be given. +C On exit, the leading N-by-N part of this array contains +C the solution matrix X of the equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C (0 < SCALE <= 1) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: equation is (almost) singular to working precision; +C perturbed values were used to solve the equation +C (but the matrices A and E are unchanged). +C +C METHOD +C +C The solution X of (1) or (2) is computed via block back +C substitution or block forward substitution, respectively. (See +C [1] and [2] for details.) +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C 8/3 * N**3 flops are required by the routine. Note that we count a +C single floating point arithmetic operation as one flop. +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDE, LDX, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) +C .. Local Scalars .. + DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, + $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 + INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) + INTEGER PIV1(4), PIV2(4) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, + $ MB02UV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Decode input parameter. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03AX', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) RETURN +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number +C of rows in this block row. +C + KL = 0 + KB = 1 +C WHILE ( KL+KB .LE. N ) DO + 20 IF ( KL+KB .LE. N ) THEN + KL = KL + KB + IF ( KL .EQ. N ) THEN + KB = 1 + ELSE + IF ( A(KL+1,KL) .NE. ZERO ) THEN + KB = 2 + ELSE + KB = 1 + END IF + END IF + KH = KL + KB - 1 +C +C Copy elements of solution already known by symmetry. +C +C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' +C + IF ( KL .GT. 1 ) THEN + DO 40 I = KL, KH + CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) + 40 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the +C number of columns in this block. +C + LL = KL - 1 + LB = 1 +C WHILE ( LL+LB .LE. N ) DO + 60 IF ( LL+LB .LE. N ) THEN + LL = LL + LB + IF ( LL .EQ. N ) THEN + LB = 1 + ELSE + IF ( A(LL+1,LL) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LH = LL + LB - 1 +C +C Update right hand sides (I). +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - +C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) + +C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) +C + IF ( LL .GT. 1 ) THEN + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, + $ A(1,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), + $ LDA, TM, 2, ONE, X(KL,LL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), + $ LDX, E(1,LL), LDE, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, ONE, E(KL,KH), + $ LDE, TM, 2, ONE, X(KH,LL), LDX ) + IF ( KB .EQ. 2 ) CALL DAXPY( LB, E(KL,KL), TM, 2, + $ X(KL,LL), LDX ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK21 + MAT(2,1) = AL11*AK12 - EL11*EK12 + MAT(2,2) = AL11*AK22 - EL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL21*AK11 + MAT(2,1) = AL12*AK11 - EL12*EK11 + MAT(2,2) = AL22*AK11 - EL22*EK11 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KL,LH) +C + ELSE +C + DIMMAT = 4 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK21 + MAT(1,3) = AL21*AK11 + MAT(1,4) = AL21*AK21 +C + MAT(2,1) = AL11*AK12 - EL11*EK12 + MAT(2,2) = AL11*AK22 - EL11*EK22 + MAT(2,3) = AL21*AK12 + MAT(2,4) = AL21*AK22 +C + MAT(3,1) = AL12*AK11 - EL12*EK11 + MAT(3,2) = AL12*AK21 + MAT(3,3) = AL22*AK11 - EL22*EK11 + MAT(3,4) = AL22*AK21 +C + MAT(4,1) = AL12*AK12 - EL12*EK12 + MAT(4,2) = AL12*AK22 - EL12*EK22 + MAT(4,3) = AL22*AK12 - EL22*EK12 + MAT(4,4) = AL22*AK22 - EL22*EK22 +C + RHS(1) = X(KL,LL) + IF ( KL .EQ. LL ) THEN + RHS(2) = X(KL,KH) + ELSE + RHS(2) = X(KH,LL) + END IF + RHS(3) = X(KL,LH) + RHS(4) = X(KH,LH) +C + END IF +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) +C +C Scaling. +C + IF ( SCALE1 .NE. ONE ) THEN + DO 80 I = 1, N + CALL DSCAL( N, SCALE1, X(1,I), 1 ) + 80 CONTINUE + SCALE = SCALE*SCALE1 + END IF +C + IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + X(KL,LH) = RHS(2) + ELSE + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + X(KL,LH) = RHS(3) + X(KH,LH) = RHS(4) + END IF +C +C Update right hand sides (II). +C +C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - +C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) +C +C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) + +C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) +C + IF ( KL .LT. LL ) THEN + CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, + $ A(LL,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), + $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) + IF ( LB .EQ. 2 ) THEN + CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) + CALL DSCAL( KB, E(LL,LL), TM, 1 ) + END IF + CALL DGEMV( 'N', KB, LB, ONE, X(KL,LL), LDX, E(LL,LH), + $ 1, ZERO, TM(1,LB), 1 ) + CALL DGEMM( 'T', 'N', LH-KH, LB, KB, ONE, E(KL,KH+1), + $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) + END IF +C + GOTO 60 + END IF +C END WHILE 60 +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Outer Loop. Compute block column X(:,LL:LH). LB denotes the +C number of columns in this block column. +C + LL = N + 1 +C WHILE ( LL .GT. 1 ) DO + 100 IF ( LL .GT. 1 ) THEN + LH = LL - 1 + IF ( LH .EQ. 1 ) THEN + LB = 1 + ELSE + IF ( A(LL-1,LL-2) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LL = LL - LB +C +C Copy elements of solution already known by symmetry. +C +C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' +C + IF ( LH .LT. N ) THEN + DO 120 I = LL, LH + CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) + 120 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the +C number of rows in this block. +C + KL = LH + 1 +C WHILE ( KL .GT. 1 ) DO + 140 IF ( KL .GT. 1 ) THEN + KH = KL - 1 + IF ( KH .EQ. 1 ) THEN + KB = 1 + ELSE + IF ( A(KL-1,KL-2) .NE. ZERO ) THEN + KB =2 + ELSE + KB = 1 + END IF + END IF + KL = KL - KB +C +C Update right hand sides (I). +C +C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - +C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' +C +C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) + +C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' +C + IF ( KH .LT. N ) THEN + CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), + $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, + $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), + $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, ONE, TM, 2, + $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) + IF ( LB .EQ. 2 ) CALL DAXPY( KB, E(LH,LH), TM(1,2), 1, + $ X(KL,LH), 1 ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = A(LL,LL)*A(KL,KL) - E(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK12 - EL11*EK12 + MAT(2,1) = AL11*AK21 + MAT(2,2) = AL11*AK22 - EL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL12*AK11 - EL12*EK11 + MAT(2,1) = AL21*AK11 + MAT(2,2) = AL22*AK11 - EL22*EK11 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KL,LH) +C + ELSE +C + DIMMAT = 4 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = AL11*AK11 - EL11*EK11 + MAT(1,2) = AL11*AK12 - EL11*EK12 + MAT(1,3) = AL12*AK11 - EL12*EK11 + MAT(1,4) = AL12*AK12 - EL12*EK12 +C + MAT(2,1) = AL11*AK21 + MAT(2,2) = AL11*AK22 - EL11*EK22 + MAT(2,3) = AL12*AK21 + MAT(2,4) = AL12*AK22 - EL12*EK22 +C + MAT(3,1) = AL21*AK11 + MAT(3,2) = AL21*AK12 + MAT(3,3) = AL22*AK11 - EL22*EK11 + MAT(3,4) = AL22*AK12 - EL22*EK12 +C + MAT(4,1) = AL21*AK21 + MAT(4,2) = AL21*AK22 + MAT(4,3) = AL22*AK21 + MAT(4,4) = AL22*AK22 - EL22*EK22 +C + RHS(1) = X(KL,LL) + IF ( KL .EQ. LL ) THEN + RHS(2) = X(KL,KH) + ELSE + RHS(2) = X(KH,LL) + END IF + RHS(3) = X(KL,LH) + RHS(4) = X(KH,LH) +C + END IF +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) +C +C Scaling. +C + IF ( SCALE1 .NE. ONE ) THEN + DO 160 I = 1, N + CALL DSCAL( N, SCALE1, X(1,I), 1 ) + 160 CONTINUE + SCALE = SCALE*SCALE1 + END IF +C + IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + X(KL,LH) = RHS(2) + ELSE + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + X(KL,LH) = RHS(3) + X(KH,LH) = RHS(4) + END IF +C +C Update right hand sides (II). +C +C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - +C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' +C +C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) + +C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' +C + IF ( KL .LT. LL ) THEN + CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, + $ X(KL,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, + $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) + CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), + $ LDE, ZERO, TM, 2 ) + IF ( KB .EQ. 2 ) THEN + CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) + CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) + END IF + CALL DGEMM( 'N', 'T', KB, LL-KL, LB, ONE, TM, 2, + $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) + END IF +C + GOTO 140 + END IF +C END WHILE 140 +C + GOTO 100 + END IF +C END WHILE 100 +C + END IF +C + RETURN +C *** Last line of SG03AX *** + END diff --git a/mex/sources/libslicot/SG03AY.f b/mex/sources/libslicot/SG03AY.f new file mode 100644 index 000000000..4f2dfe5ab --- /dev/null +++ b/mex/sources/libslicot/SG03AY.f @@ -0,0 +1,686 @@ + SUBROUTINE SG03AY( TRANS, N, A, LDA, E, LDE, X, LDX, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X either the reduced generalized continuous-time +C Lyapunov equation +C +C T T +C A * X * E + E * X * A = SCALE * Y (1) +C +C or +C +C T T +C A * X * E + E * X * A = SCALE * Y (2) +C +C where the right hand side Y is symmetric. A, E, Y, and the +C solution X are N-by-N matrices. The pencil A - lambda * E must be +C in generalized Schur form (A upper quasitriangular, E upper +C triangular). SCALE is an output scale factor, set to avoid +C overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading N-by-N part of this array must +C contain the right hand side matrix Y of the equation. Only +C the upper triangular part of this matrix need be given. +C On exit, the leading N-by-N part of this array contains +C the solution matrix X of the equation. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C (0 < SCALE <= 1) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: equation is (almost) singular to working precision; +C perturbed values were used to solve the equation +C (but the matrices A and E are unchanged). +C +C METHOD +C +C The solution X of (1) or (2) is computed via block back +C substitution or block forward substitution, respectively. (See +C [1] and [2] for details.) +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C 8/3 * N**3 flops are required by the routine. Note that we count a +C single floating point arithmetic operation as one flop. +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDE, LDX, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), E(LDE,*), X(LDX,*) +C .. Local Scalars .. + INTEGER DIMMAT, I, INFO1, KB, KH, KL, LB, LH, LL + DOUBLE PRECISION AK11, AK12, AK21, AK22, AL11, AL12, AL21, AL22, + $ EK11, EK12, EK22, EL11, EL12, EL22, SCALE1 + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) + INTEGER PIV1(4), PIV2(4) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DSCAL, MB02UU, + $ MB02UV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C +C Decode input parameters. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDX .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03AY', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) RETURN +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Outer Loop. Compute block row X(KL:KH,:). KB denotes the number +C of rows in this block row. +C + KL = 0 + KB = 1 +C WHILE ( KL+KB .LE. N ) DO + 20 IF ( KL+KB .LE. N ) THEN + KL = KL + KB + IF ( KL .EQ. N ) THEN + KB = 1 + ELSE + IF ( A(KL+1,KL) .NE. ZERO ) THEN + KB = 2 + ELSE + KB = 1 + END IF + END IF + KH = KL + KB - 1 +C +C Copy elements of solution already known by symmetry. +C +C X(KL:KH,1:KL-1) = X(1:KL-1,KL:KH)' +C + IF ( KL .GT. 1 ) THEN + DO 40 I = KL, KH + CALL DCOPY( KL-1, X(1,I), 1, X(I,1), LDX ) + 40 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). LB denotes the +C number of columns in this block. +C + LL = KL - 1 + LB = 1 +C WHILE ( LL+LB .LE. N ) DO + 60 IF ( LL+LB .LE. N ) THEN + LL = LL + LB + IF ( LL .EQ. N ) THEN + LB = 1 + ELSE + IF ( A(LL+1,LL) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LH = LL + LB - 1 +C +C Update right hand sides (I). +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - +C A(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*E(1:LL-1,LL:LH)) +C +C X(KL:LH,LL:LH) = X(KL:LH,LL:LH) - +C E(KL:KH,KL:LH)'*(X(KL:KH,1:LL-1)*A(1:LL-1,LL:LH)) +C + IF ( LL .GT. 1 ) THEN + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, + $ E(1,LL), LDE, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KL+1, LB, KB, MONE, A(KL,KL), + $ LDA, TM, 2, ONE, X(KL,LL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, LL-1, ONE, X(KL,1), LDX, + $ A(1,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH+1, LB, KB, MONE, E(KL,KH), + $ LDE, TM, 2, ONE, X(KH,LL), LDX ) + IF ( KB .EQ. 2 ) CALL DAXPY( LB, -E(KL,KL), TM, 2, + $ X(KL,LL), LDX ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL11*AK21 + MAT(2,1) = EL11*AK12 + AL11*EK12 + MAT(2,2) = EL11*AK22 + AL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = AL21*EK11 + MAT(2,1) = EL12*AK11 + AL12*EK11 + MAT(2,2) = EL22*AK11 + AL22*EK11 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KL,LH) +C + ELSE +C + DIMMAT = 4 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL11*AK21 + MAT(1,3) = AL21*EK11 + MAT(1,4) = ZERO +C + MAT(2,1) = EL11*AK12 + AL11*EK12 + MAT(2,2) = EL11*AK22 + AL11*EK22 + MAT(2,3) = AL21*EK12 + MAT(2,4) = AL21*EK22 +C + MAT(3,1) = EL12*AK11 + AL12*EK11 + MAT(3,2) = EL12*AK21 + MAT(3,3) = EL22*AK11 + AL22*EK11 + MAT(3,4) = EL22*AK21 +C + MAT(4,1) = EL12*AK12 + AL12*EK12 + MAT(4,2) = EL12*AK22 + AL12*EK22 + MAT(4,3) = EL22*AK12 + AL22*EK12 + MAT(4,4) = EL22*AK22 + AL22*EK22 +C + RHS(1) = X(KL,LL) + IF ( KL .EQ. LL ) THEN + RHS(2) = X(KL,KH) + ELSE + RHS(2) = X(KH,LL) + END IF + RHS(3) = X(KL,LH) + RHS(4) = X(KH,LH) +C + END IF +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) +C +C Scaling. +C + IF ( SCALE1 .NE. ONE ) THEN + DO 80 I = 1, N + CALL DSCAL( N, SCALE1, X(1,I), 1 ) + 80 CONTINUE + SCALE = SCALE*SCALE1 + END IF +C + IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + X(KL,LH) = RHS(2) + ELSE + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + X(KL,LH) = RHS(3) + X(KH,LH) = RHS(4) + END IF +C +C Update right hand sides (II). +C +C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - +C A(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*E(LL:LH,LL:LH)) +C +C X(KH+1:LH,LL:LH) = X(KH+1:LH,LL:LH) - +C E(KL:KH,KH+1:LH)'*(X(KL:KH,LL:LH)*A(LL:LH,LL:LH)) +C + IF ( KL .LT. LL ) THEN + IF ( LB .EQ. 2 ) + $ CALL DGEMV( 'N', KB, 2, ONE, X(KL,LL), LDX, + $ E(LL,LH), 1, ZERO, TM(1,2), 1 ) + CALL DCOPY( KB, X(KL,LL), 1, TM, 1 ) + CALL DSCAL( KB, E(LL,LL), TM, 1 ) + CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, A(KL,KH+1), + $ LDA, TM, 2, ONE, X(KH+1,LL), LDX ) + CALL DGEMM( 'N', 'N', KB, LB, LB, ONE, X(KL,LL), LDX, + $ A(LL,LL), LDA, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', LH-KH, LB, KB, MONE, E(KL,KH+1), + $ LDE, TM, 2, ONE, X(KH+1,LL), LDX ) + END IF +C + GOTO 60 + END IF +C END WHILE 60 +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Outer Loop. Compute block column X(:,LL:LH). LB denotes the +C number of columns in this block column. +C + LL = N + 1 +C WHILE ( LL .GT. 1 ) DO + 100 IF ( LL .GT. 1 ) THEN + LH = LL - 1 + IF ( LH .EQ. 1 ) THEN + LB = 1 + ELSE + IF ( A(LL-1,LL-2) .NE. ZERO ) THEN + LB = 2 + ELSE + LB = 1 + END IF + END IF + LL = LL - LB +C +C Copy elements of solution already known by symmetry. +C +C X(LH+1:N,LL:LH) = X(LL:LH,LH+1:N)' +C + IF ( LH .LT. N ) THEN + DO 120 I = LL, LH + CALL DCOPY( N-LH, X(I,LH+1), LDX, X(LH+1,I), 1 ) + 120 CONTINUE + END IF +C +C Inner Loop. Compute block X(KL:KH,LL:LH). KB denotes the +C number of rows in this block. +C + KL = LH + 1 +C WHILE ( KL .GT. 1 ) DO + 140 IF ( KL .GT. 1 ) THEN + KH = KL - 1 + IF ( KH .EQ. 1 ) THEN + KB = 1 + ELSE + IF ( A(KL-1,KL-2) .NE. ZERO ) THEN + KB = 2 + ELSE + KB = 1 + END IF + END IF + KL = KL - KB +C +C Update right hand sides (I). +C +C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - +C (A(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*E(KL:LH,LL:LH)' +C +C X(KL:KH,KL:LH) = X(KL:KH,KL:LH) - +C (E(KL:KH,KH+1:N)*X(KH+1:N,LL:LH))*A(KL:LH,LL:LH)' +C + IF ( KH .LT. N ) THEN + CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, A(KL,KH+1), + $ LDA, X(KH+1,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LL-KL+1, LB, MONE, TM, 2, + $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) + IF ( LB .EQ. 2 ) CALL DAXPY( KB, -E(LH,LH), TM(1,2), + $ 1, X(KL,LH), 1 ) + CALL DGEMM( 'N', 'N', KB, LB, N-KH, ONE, E(KL,KH+1), + $ LDE, X(KH+1,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LH-KL+1, LB, MONE, TM, 2, + $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) + END IF +C +C Solve small Sylvester equations of order at most (2,2). +C + IF ( KB.EQ.1 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 1 +C + MAT(1,1) = E(LL,LL)*A(KL,KL) + A(LL,LL)*E(KL,KL) +C + RHS(1) = X(KL,LL) +C + ELSEIF ( KB.EQ.2 .AND. LB.EQ.1 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL11*AK12 + AL11*EK12 + MAT(2,1) = EL11*AK21 + MAT(2,2) = EL11*AK22 + AL11*EK22 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KH,LL) +C + ELSEIF ( KB.EQ.1 .AND. LB.EQ.2 ) THEN +C + DIMMAT = 2 +C + AK11 = A(KL,KL) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL12*AK11 + AL12*EK11 + MAT(2,1) = AL21*EK11 + MAT(2,2) = EL22*AK11 + AL22*EK11 +C + RHS(1) = X(KL,LL) + RHS(2) = X(KL,LH) +C + ELSE +C + DIMMAT = 4 +C + AK11 = A(KL,KL) + AK12 = A(KL,KH) + AK21 = A(KH,KL) + AK22 = A(KH,KH) +C + AL11 = A(LL,LL) + AL12 = A(LL,LH) + AL21 = A(LH,LL) + AL22 = A(LH,LH) +C + EK11 = E(KL,KL) + EK12 = E(KL,KH) + EK22 = E(KH,KH) +C + EL11 = E(LL,LL) + EL12 = E(LL,LH) + EL22 = E(LH,LH) +C + MAT(1,1) = EL11*AK11 + AL11*EK11 + MAT(1,2) = EL11*AK12 + AL11*EK12 + MAT(1,3) = EL12*AK11 + AL12*EK11 + MAT(1,4) = EL12*AK12 + AL12*EK12 +C + MAT(2,1) = EL11*AK21 + MAT(2,2) = EL11*AK22 + AL11*EK22 + MAT(2,3) = EL12*AK21 + MAT(2,4) = EL12*AK22 + AL12*EK22 +C + MAT(3,1) = AL21*EK11 + MAT(3,2) = AL21*EK12 + MAT(3,3) = EL22*AK11 + AL22*EK11 + MAT(3,4) = EL22*AK12 + AL22*EK12 +C + MAT(4,1) = ZERO + MAT(4,2) = AL21*EK22 + MAT(4,3) = EL22*AK21 + MAT(4,4) = EL22*AK22 + AL22*EK22 +C + RHS(1) = X(KL,LL) + IF ( KL .EQ. LL ) THEN + RHS(2) = X(KL,KH) + ELSE + RHS(2) = X(KH,LL) + END IF + RHS(3) = X(KL,LH) + RHS(4) = X(KH,LH) +C + END IF +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) +C +C Scaling. +C + IF ( SCALE1 .NE. ONE ) THEN + DO 160 I = 1, N + CALL DSCAL( N, SCALE1, X(1,I), 1 ) + 160 CONTINUE + SCALE = SCALE*SCALE1 + END IF +C + IF ( LB.EQ.1 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + ELSEIF ( LB.EQ.1 .AND. KB.EQ.2 ) THEN + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + ELSEIF ( LB.EQ.2 .AND. KB.EQ.1 ) THEN + X(KL,LL) = RHS(1) + X(KL,LH) = RHS(2) + ELSE + X(KL,LL) = RHS(1) + X(KH,LL) = RHS(2) + X(KL,LH) = RHS(3) + X(KH,LH) = RHS(4) + END IF +C +C Update right hand sides (II). +C +C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - +C (A(KL:KH,KL:KH)*X(KL:KH,LL:LH))*E(KL:LL-1,LL:LH)' +C +C X(KL:KH,KL:LL-1) = X(KL:KH,KL:LL-1) - +C (E(KL:KH,KL:KH)*X(KL:KH,LL:LH))*A(KL:LL-1,LL:LH)' +C + IF ( KL .LT. LL ) THEN + CALL DGEMM( 'N', 'N', KB, LB, KB, ONE, A(KL,KL), LDA, + $ X(KL,LL), LDX, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, + $ E(KL,LL), LDE, ONE, X(KL,KL), LDX ) + CALL DGEMV( 'T', KB, LB, ONE, X(KL,LL), LDX, E(KL,KL), + $ LDE, ZERO, TM, 2 ) + IF ( KB .EQ. 2 ) THEN + CALL DCOPY( LB, X(KH,LL), LDX, TM(2,1), 2 ) + CALL DSCAL( LB, E(KH,KH), TM(2,1), 2 ) + END IF + CALL DGEMM( 'N', 'T', KB, LL-KL, LB, MONE, TM, 2, + $ A(KL,LL), LDA, ONE, X(KL,KL), LDX ) + END IF +C + GOTO 140 + END IF +C END WHILE 140 +C + GOTO 100 + END IF +C END WHILE 100 +C + END IF +C + RETURN +C *** Last line of SG03AY *** + END diff --git a/mex/sources/libslicot/SG03BD.f b/mex/sources/libslicot/SG03BD.f new file mode 100644 index 000000000..6bcd7400b --- /dev/null +++ b/mex/sources/libslicot/SG03BD.f @@ -0,0 +1,814 @@ + SUBROUTINE SG03BD( DICO, FACT, TRANS, N, M, A, LDA, E, LDE, Q, + $ LDQ, Z, LDZ, B, LDB, SCALE, ALPHAR, ALPHAI, + $ BETA, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor U of the matrix X, +C +C T +C X = op(U) * op(U), +C +C which is the solution of either the generalized +C c-stable continuous-time Lyapunov equation +C +C T T +C op(A) * X * op(E) + op(E) * X * op(A) +C +C 2 T +C = - SCALE * op(B) * op(B), (1) +C +C or the generalized d-stable discrete-time Lyapunov equation +C +C T T +C op(A) * X * op(A) - op(E) * X * op(E) +C +C 2 T +C = - SCALE * op(B) * op(B), (2) +C +C without first finding X and without the need to form the matrix +C op(B)**T * op(B). +C +C op(K) is either K or K**T for K = A, B, E, U. A and E are N-by-N +C matrices, op(B) is an M-by-N matrix. The resulting matrix U is an +C N-by-N upper triangular matrix with non-negative entries on its +C main diagonal. SCALE is an output scale factor set to avoid +C overflow in U. +C +C In the continuous-time case (1) the pencil A - lambda * E must be +C c-stable (that is, all eigenvalues must have negative real parts). +C In the discrete-time case (2) the pencil A - lambda * E must be +C d-stable (that is, the moduli of all eigenvalues must be smaller +C than one). +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies which type of the equation is considered: +C = 'C': Continuous-time equation (1); +C = 'D': Discrete-time equation (2). +C +C FACT CHARACTER*1 +C Specifies whether the generalized real Schur +C factorization of the pencil A - lambda * E is supplied +C on entry or not: +C = 'N': Factorization is not supplied; +C = 'F': Factorization is supplied. +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': op(A) = A, op(E) = E; +C = 'T': op(A) = A**T, op(E) = E**T. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of rows in the matrix op(B). M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C Hessenberg part of this array must contain the +C generalized Schur factor A_s of the matrix A (see +C definition (3) in section METHOD). A_s must be an upper +C quasitriangular matrix. The elements below the upper +C Hessenberg part of the array A are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the matrix A. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor A_s of the matrix A. (A_s is +C an upper quasitriangular matrix.) +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, if FACT = 'F', then the leading N-by-N upper +C triangular part of this array must contain the +C generalized Schur factor E_s of the matrix E (see +C definition (4) in section METHOD). The elements below the +C upper triangular part of the array E are not referenced. +C If FACT = 'N', then the leading N-by-N part of this +C array must contain the coefficient matrix E of the +C equation. +C On exit, the leading N-by-N part of this array contains +C the generalized Schur factor E_s of the matrix E. (E_s is +C an upper triangular matrix.) +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Q from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Q need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Q from the generalized Schur +C factorization. +C +C LDQ INTEGER +C The leading dimension of the array Q. LDQ >= MAX(1,N). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C On entry, if FACT = 'F', then the leading N-by-N part of +C this array must contain the orthogonal matrix Z from +C the generalized Schur factorization (see definitions (3) +C and (4) in section METHOD). +C If FACT = 'N', Z need not be set on entry. +C On exit, the leading N-by-N part of this array contains +C the orthogonal matrix Z from the generalized Schur +C factorization. +C +C LDZ INTEGER +C The leading dimension of the array Z. LDZ >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N1) +C On entry, if TRANS = 'T', the leading N-by-M part of this +C array must contain the matrix B and N1 >= MAX(M,N). +C If TRANS = 'N', the leading M-by-N part of this array +C must contain the matrix B and N1 >= N. +C On exit, the leading N-by-N part of this array contains +C the Cholesky factor U of the solution matrix X of the +C problem, X = op(U)**T * op(U). +C If M = 0 and N > 0, then U is set to zero. +C +C LDB INTEGER +C The leading dimension of the array B. +C If TRANS = 'T', LDB >= MAX(1,N). +C If TRANS = 'N', LDB >= MAX(1,M,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in U. +C 0 < SCALE <= 1. +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C If INFO = 0, 3, 5, 6, or 7, then +C (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, are the +C eigenvalues of the matrix pencil A - lambda * E. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= MAX(1,4*N,6*N-6), if FACT = 'N'; +C LDWORK >= MAX(1,2*N,6*N-6), if FACT = 'F'. +C For good performance, LDWORK should be larger. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the pencil A - lambda * E is (nearly) singular; +C perturbed values were used to solve the equation +C (but the reduced (quasi)triangular matrices A and E +C are unchanged); +C = 2: FACT = 'F' and the matrix contained in the upper +C Hessenberg part of the array A is not in upper +C quasitriangular form; +C = 3: FACT = 'F' and there is a 2-by-2 block on the main +C diagonal of the pencil A_s - lambda * E_s whose +C eigenvalues are not conjugate complex; +C = 4: FACT = 'N' and the pencil A - lambda * E cannot be +C reduced to generalized Schur form: LAPACK routine +C DGEGS has failed to converge; +C = 5: DICO = 'C' and the pencil A - lambda * E is not +C c-stable; +C = 6: DICO = 'D' and the pencil A - lambda * E is not +C d-stable; +C = 7: the LAPACK routine DSYEVX utilized to factorize M3 +C failed to converge in the discrete-time case (see +C section METHOD for SLICOT Library routine SG03BU). +C This error is unlikely to occur. +C +C METHOD +C +C An extension [2] of Hammarling's method [1] to generalized +C Lyapunov equations is utilized to solve (1) or (2). +C +C First the pencil A - lambda * E is reduced to real generalized +C Schur form A_s - lambda * E_s by means of orthogonal +C transformations (QZ-algorithm): +C +C A_s = Q**T * A * Z (upper quasitriangular) (3) +C +C E_s = Q**T * E * Z (upper triangular). (4) +C +C If the pencil A - lambda * E has already been factorized prior to +C calling the routine however, then the factors A_s, E_s, Q and Z +C may be supplied and the initial factorization omitted. +C +C Depending on the parameters TRANS and M the N-by-N upper +C triangular matrix B_s is defined as follows. In any case Q_B is +C an M-by-M orthogonal matrix, which need not be accumulated. +C +C 1. If TRANS = 'N' and M < N, B_s is the upper triangular matrix +C from the QR-factorization +C +C ( Q_B O ) ( B * Z ) +C ( ) * B_s = ( ), +C ( O I ) ( O ) +C +C where the O's are zero matrices of proper size and I is the +C identity matrix of order N-M. +C +C 2. If TRANS = 'N' and M >= N, B_s is the upper triangular matrix +C from the (rectangular) QR-factorization +C +C ( B_s ) +C Q_B * ( ) = B * Z, +C ( O ) +C +C where O is the (M-N)-by-N zero matrix. +C +C 3. If TRANS = 'T' and M < N, B_s is the upper triangular matrix +C from the RQ-factorization +C +C ( Q_B O ) +C (B_s O ) * ( ) = ( Q**T * B O ). +C ( O I ) +C +C 4. If TRANS = 'T' and M >= N, B_s is the upper triangular matrix +C from the (rectangular) RQ-factorization +C +C ( B_s O ) * Q_B = Q**T * B, +C +C where O is the N-by-(M-N) zero matrix. +C +C Assuming SCALE = 1, the transformation of A, E and B described +C above leads to the reduced continuous-time equation +C +C T T +C op(A_s) op(U_s) op(U_s) op(E_s) +C +C T T +C + op(E_s) op(U_s) op(U_s) op(A_s) +C +C T +C = - op(B_s) op(B_s) (5) +C +C or to the reduced discrete-time equation +C +C T T +C op(A_s) op(U_s) op(U_s) op(A_s) +C +C T T +C - op(E_s) op(U_s) op(U_s) op(E_s) +C +C T +C = - op(B_s) op(B_s). (6) +C +C For brevity we restrict ourself to equation (5) and the case +C TRANS = 'N'. The other three cases can be treated in a similar +C fashion. +C +C We use the following partitioning for the matrices A_s, E_s, B_s +C and U_s +C +C ( A11 A12 ) ( E11 E12 ) +C A_s = ( ), E_s = ( ), +C ( 0 A22 ) ( 0 E22 ) +C +C ( B11 B12 ) ( U11 U12 ) +C B_s = ( ), U_s = ( ). (7) +C ( 0 B22 ) ( 0 U22 ) +C +C The size of the (1,1)-blocks is 1-by-1 (iff A_s(2,1) = 0.0) or +C 2-by-2. +C +C We compute U11 and U12**T in three steps. +C +C Step I: +C +C From (5) and (7) we get the 1-by-1 or 2-by-2 equation +C +C T T T T +C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 +C +C T +C = - B11 * B11. +C +C For brevity, details are omitted here. See [2]. The technique +C for computing U11 is similar to those applied to standard +C Lyapunov equations in Hammarling's algorithm ([1], section 6). +C +C Furthermore, the auxiliary matrices M1 and M2 defined as +C follows +C +C -1 -1 +C M1 = U11 * A11 * E11 * U11 +C +C -1 -1 +C M2 = B11 * E11 * U11 +C +C are computed in a numerically reliable way. +C +C Step II: +C +C The generalized Sylvester equation +C +C T T T T +C A22 * U12 + E22 * U12 * M1 = +C +C T T T T T +C - B12 * M2 - A12 * U11 - E12 * U11 * M1 +C +C is solved for U12**T. +C +C Step III: +C +C It can be shown that +C +C T T T T +C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = +C +C T T +C - B22 * B22 - y * y (8) +C +C holds, where y is defined as +C +C T T T T T T +C y = B12 - ( E12 * U11 + E22 * U12 ) * M2 . +C +C If B22_tilde is the square triangular matrix arising from the +C (rectangular) QR-factorization +C +C ( B22_tilde ) ( B22 ) +C Q_B_tilde * ( ) = ( ), +C ( O ) ( y**T ) +C +C where Q_B_tilde is an orthogonal matrix of order N, then +C +C T T T +C - B22 * B22 - y * y = - B22_tilde * B22_tilde. +C +C Replacing the right hand side in (8) by the term +C - B22_tilde**T * B22_tilde leads to a reduced generalized +C Lyapunov equation of lower dimension compared to (5). +C +C The recursive application of the steps I to III yields the +C solution U_s of the equation (5). +C +C It remains to compute the solution matrix U of the original +C problem (1) or (2) from the matrix U_s. To this end we transform +C the solution back (with respect to the transformation that led +C from (1) to (5) (from (2) to (6)) and apply the QR-factorization +C (RQ-factorization). The upper triangular solution matrix U is +C obtained by +C +C Q_U * U = U_s * Q**T (if TRANS = 'N') +C +C or +C +C U * Q_U = Z * U_s (if TRANS = 'T') +C +C where Q_U is an N-by-N orthogonal matrix. Again, the orthogonal +C matrix Q_U need not be accumulated. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-323, 1982. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The number of flops required by the routine is given by the +C following table. Note that we count a single floating point +C arithmetic operation as one flop. +C +C | FACT = 'F' FACT = 'N' +C ---------+-------------------------------------------------- +C M <= N | (13*N**3+6*M*N**2 (211*N**3+6*M*N**2 +C | +6*M**2*N-2*M**3)/3 +6*M**2*N-2*M**3)/3 +C | +C M > N | (11*N**3+12*M*N**2)/3 (209*N**3+12*M*N**2)/3 +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if DICO = 'D' and the pencil A - lambda * E has a pair of almost +C reciprocal eigenvalues, or DICO = 'C' and the pencil has an almost +C degenerate pair of eigenvalues, then the Lyapunov equation will be +C ill-conditioned. Perturbed values were used to solve the equation. +C A condition estimate can be obtained from the routine SG03AD. +C When setting the error indicator INFO, the routine does not test +C for near instability in the equation but only for exact +C instability. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C May 1999 (V. Sima). +C March 2002 (A. Varga). +C Feb. 2004 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, TWO, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDB, LDE, LDQ, LDWORK, LDZ, M, N + CHARACTER DICO, FACT, TRANS +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), + $ BETA(*), DWORK(*), E(LDE,*), Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + DOUBLE PRECISION S1, S2, SAFMIN, WI, WR1, WR2 + INTEGER I, INFO1, MINMN, MINWRK, OPTWRK + LOGICAL ISDISC, ISFACT, ISTRAN +C .. Local Arrays .. + DOUBLE PRECISION E1(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + LOGICAL LSAME + EXTERNAL DLAMCH, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEGS, DGEMM, DGEMV, DGEQRF, DGERQF, + $ DLACPY, DLAG2, DLASET, DSCAL, DTRMM, SG03BU, + $ SG03BV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SIGN +C .. Executable Statements .. +C +C Decode input parameters. +C + ISDISC = LSAME( DICO, 'D' ) + ISFACT = LSAME( FACT, 'F' ) + ISTRAN = LSAME( TRANS, 'T' ) +C +C Compute minimal workspace. +C + IF (ISFACT ) THEN + MINWRK = MAX( 1, 2*N, 6*N-6 ) + ELSE + MINWRK = MAX( 1, 4*N, 6*N-6 ) + END IF +C +C Check the scalar input parameters. +C + IF ( .NOT.( ISDISC .OR. LSAME( DICO, 'C' ) ) ) THEN + INFO = -1 + ELSEIF ( .NOT.( ISFACT .OR. LSAME( FACT, 'N' ) ) ) THEN + INFO = -2 + ELSEIF ( .NOT.( ISTRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN + INFO = -3 + ELSEIF ( N .LT. 0 ) THEN + INFO = -4 + ELSEIF ( M .LT. 0 ) THEN + INFO = -5 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -7 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -9 + ELSEIF ( LDQ .LT. MAX( 1, N ) ) THEN + INFO = -11 + ELSEIF ( LDZ .LT. MAX( 1, N ) ) THEN + INFO = -13 + ELSEIF ( ( ISTRAN .AND. ( LDB .LT. MAX( 1, N ) ) ) .OR. + $ ( .NOT.ISTRAN .AND. ( LDB .LT. MAX( 1, M, N ) ) ) ) THEN + INFO = -15 + ELSEIF ( LDWORK .LT. MINWRK ) THEN + INFO = -21 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03BD', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + MINMN = MIN( M, N ) + IF ( MINMN .EQ. 0 ) THEN + IF ( N.GT.0 ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDB ) + DWORK(1) = ONE + RETURN + ENDIF +C + IF ( ISFACT ) THEN +C +C Make sure the upper Hessenberg part of A is quasitriangular. +C + DO 20 I = 1, N-2 + IF ( A(I+1,I).NE.ZERO .AND. A(I+2,I+1).NE.ZERO ) THEN + INFO = 2 + RETURN + END IF + 20 CONTINUE + END IF +C + IF ( .NOT.ISFACT ) THEN +C +C Reduce the pencil A - lambda * E to generalized Schur form. +C +C A := Q**T * A * Z (upper quasitriangular) +C E := Q**T * E * Z (upper triangular) +C +C ( Workspace: >= MAX(1,4*N) ) +C + CALL DGEGS( 'Vectors', 'Vectors', N, A, LDA, E, LDE, ALPHAR, + $ ALPHAI, BETA, Q, LDQ, Z, LDZ, DWORK, LDWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 4 + RETURN + END IF + OPTWRK = INT( DWORK(1) ) + ELSE + OPTWRK = MINWRK + END IF +C + IF ( ISFACT ) THEN +C +C If the matrix pencil A - lambda * E has been in generalized +C Schur form on entry, compute its eigenvalues. +C + SAFMIN = DLAMCH( 'Safe minimum' ) + E1(2,1) = ZERO + I = 1 +C WHILE ( I .LE. N ) DO + 30 IF ( I .LE. N ) THEN + IF ( ( I.EQ.N ) .OR. ( A(MIN( I+1, N ),I).EQ.ZERO ) ) THEN + ALPHAR(I) = A(I,I) + ALPHAI(I) = ZERO + BETA(I) = E(I,I) + I = I+1 + ELSE + E1(1,1) = E(I,I) + E1(1,2) = E(I,I+1) + E1(2,2) = E(I+1,I+1) + CALL DLAG2( A(I,I), LDA, E1, 2, SAFMIN, S1, S2, WR1, WR2, + $ WI ) + IF ( WI .EQ. ZERO ) INFO = 3 + ALPHAR(I) = WR1 + ALPHAI(I) = WI + BETA(I) = S1 + ALPHAR(I+1) = WR2 + ALPHAI(I+1) = -WI + BETA(I+1) = S2 + I = I+2 + END IF + GOTO 30 + END IF +C END WHILE 30 + IF ( INFO.NE.0 ) RETURN + END IF +C +C Check on the stability of the matrix pencil A - lambda * E. +C + DO 40 I = 1, N + IF ( ISDISC ) THEN + IF ( DLAPY2( ALPHAR(I), ALPHAI(I) ) .GE. ABS( BETA(I) ) ) + $ THEN + INFO = 6 + RETURN + END IF + ELSE + IF ( ( ALPHAR(I).EQ.ZERO ) .OR. ( BETA(I).EQ.ZERO ) .OR. + $ ( SIGN( ONE,ALPHAR(I) )*SIGN( ONE, BETA(I) ) .GE. ZERO) ) + $ THEN + INFO = 5 + RETURN + END IF + END IF + 40 CONTINUE +C +C Transformation of the right hand side. +C +C B := B * Z or B := Q**T * B +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: max(1,N) ) +C + IF ( .NOT.ISTRAN ) THEN + IF ( LDWORK .GE. N*M ) THEN + CALL DGEMM( 'NoTranspose', 'NoTranspose', M, N, N, ONE, B, + $ LDB, Z, LDZ, ZERO, DWORK, M ) + CALL DLACPY( 'All', M, N, DWORK, M, B, LDB ) + ELSE + DO 60 I = 1, M + CALL DCOPY( N, B(I,1), LDB, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, + $ ZERO, B(I,1), LDB ) + 60 CONTINUE + END IF + IF ( M .LT. N ) + $ CALL DLASET( 'All', N-M, N, ZERO, ZERO, B(M+1,1), LDB ) + ELSE + IF ( LDWORK .GE. N*M ) THEN + CALL DLACPY( 'All', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, Q, + $ LDQ, DWORK, N, ZERO, B, LDB ) + ELSE + DO 80 I = 1, M + CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, + $ ZERO, B(1,I), 1 ) + 80 CONTINUE + END IF + IF ( M .LT. N ) + $ CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,M+1), LDB ) + END IF + OPTWRK = MAX( OPTWRK, N*M ) +C +C Overwrite B with the triangular matrix of its QR-factorization +C or its RQ-factorization. +C (The entries on the main diagonal are non-negative.) +C +C ( Workspace: >= max(1,2*N) ) +C + IF ( .NOT.ISTRAN ) THEN + IF ( M .GE. 2 ) THEN + CALL DGEQRF( M, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, + $ INFO1 ) + CALL DLASET( 'Lower', MAX( M, N )-1, MIN( M, N ), ZERO, + $ ZERO, B(2,1), LDB ) + END IF + DO 100 I = 1, MINMN + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) + 100 CONTINUE + ELSE + IF ( M .GE. 2 ) THEN + CALL DGERQF( N, M, B, LDB, DWORK, DWORK(N+1), LDWORK-N, + $ INFO1 ) + IF ( N .GE. M ) THEN + CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, B(N-M+2,1), + $ LDB ) + IF ( N .GT. M ) THEN + DO 120 I = M, 1, -1 + CALL DCOPY( N, B(1,I), 1, B(1,I+N-M), 1 ) + 120 CONTINUE + CALL DLASET( 'All', N, N-M, ZERO, ZERO, B(1,1), LDB ) + END IF + ELSE + IF ( N .GT. 1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, + $ B(2,M-N+1), LDB ) + DO 140 I = 1, N + CALL DCOPY( N, B(1,M-N+I), 1, B(1,I), 1 ) + 140 CONTINUE + CALL DLASET( 'All', N, M-N, ZERO, ZERO, B(1,N+1), LDB ) + END IF + ELSE + IF ( N .NE. 1 ) THEN + CALL DCOPY( N, B(1,1), 1, B(1,N), 1 ) + CALL DLASET( 'All', N, 1, ZERO, ZERO, B(1,1), LDB ) + END IF + END IF + DO 160 I = N - MINMN + 1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( I, MONE, B(1,I), 1 ) + 160 CONTINUE + END IF + OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) +C +C Solve the reduced generalized Lyapunov equation. +C +C ( Workspace: 6*N-6 ) +C + IF ( ISDISC ) THEN + CALL SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + IF ( INFO1 .EQ. 1 ) INFO = 1 + IF ( INFO1 .EQ. 2 ) INFO = 3 + IF ( INFO1 .EQ. 3 ) INFO = 6 + IF ( INFO1 .EQ. 4 ) INFO = 7 + IF ( INFO .NE. 1 ) + $ RETURN + END IF + ELSE + CALL SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, DWORK, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + IF ( INFO1 .EQ. 1 ) INFO = 1 + IF ( INFO1 .GE. 2 ) INFO = 3 + IF ( INFO1 .EQ. 3 ) INFO = 5 + IF ( INFO .NE. 1 ) + $ RETURN + END IF + END IF +C +C Transform the solution matrix back. +C +C U := U * Q**T or U := Z * U +C +C Use BLAS 3 if there is enough workspace. Otherwise, use BLAS 2. +C +C ( Workspace: max(1,N) ) +C + IF ( .NOT.ISTRAN ) THEN + IF ( LDWORK .GE. N*N ) THEN + CALL DLACPY( 'All', N, N, Q, LDQ, DWORK, N ) + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'NonUnit', N, N, + $ ONE, B, LDB, DWORK, N) + DO 170 I = 1, N + CALL DCOPY( N, DWORK(N*(I-1)+1), 1, B(I,1), LDB ) + 170 CONTINUE + ELSE + DO 180 I = 1, N + CALL DCOPY( N-I+1, B(I,I), LDB, DWORK, 1 ) + CALL DGEMV( 'NoTranspose', N, N-I+1, ONE, Q(1,I), LDQ, + $ DWORK, 1, ZERO, B(I,1), LDB ) + 180 CONTINUE + END IF + ELSE + IF ( LDWORK .GE. N*N ) THEN + CALL DLACPY( 'All', N, N, Z, LDZ, DWORK, N ) + CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, + $ N, ONE, B, LDB, DWORK, N ) + CALL DLACPY( 'All', N, N, DWORK, N, B, LDB ) + ELSE + DO 200 I = 1, N + CALL DCOPY( I, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'NoTranspose', N, I, ONE, Z, LDZ, DWORK, 1, + $ ZERO, B(1,I), 1 ) + 200 CONTINUE + END IF + END IF + OPTWRK = MAX( OPTWRK, N*N ) +C +C Overwrite U with the triangular matrix of its QR-factorization +C or its RQ-factorization. +C (The entries on the main diagonal are non-negative.) +C +C ( Workspace: >= max(1,2*N) ) +C + IF ( .NOT.ISTRAN ) THEN + CALL DGEQRF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) + IF ( N .GT. 1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) + DO 220 I = 1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( N+1-I, MONE, B(I,I), LDB ) + 220 CONTINUE + ELSE + CALL DGERQF( N, N, B, LDB, DWORK, DWORK(N+1), LDWORK-N, INFO1 ) + IF ( N .GT. 1 ) + $ CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, B(2,1), LDB ) + DO 240 I = 1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( I, MONE, B(1,I), 1 ) + 240 CONTINUE + END IF + OPTWRK = MAX( OPTWRK, INT( DWORK(N+1) ) + N ) +C + DWORK(1) = DBLE( MAX( OPTWRK, MINWRK ) ) + RETURN +C *** Last line of SG03BD *** + END diff --git a/mex/sources/libslicot/SG03BU.f b/mex/sources/libslicot/SG03BU.f new file mode 100644 index 000000000..0e1084f96 --- /dev/null +++ b/mex/sources/libslicot/SG03BU.f @@ -0,0 +1,696 @@ + SUBROUTINE SG03BU( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor U of the matrix X, X = U**T * U or +C X = U * U**T, which is the solution of the generalized d-stable +C discrete-time Lyapunov equation +C +C T T 2 T +C A * X * A - E * X * E = - SCALE * B * B, (1) +C +C or the transposed equation +C +C T T 2 T +C A * X * A - E * X * E = - SCALE * B * B , (2) +C +C respectively, where A, E, B, and U are real N-by-N matrices. The +C Cholesky factor U of the solution is computed without first +C finding X. The pencil A - lambda * E must be in generalized Schur +C form ( A upper quasitriangular, E upper triangular ). Moreover, it +C must be d-stable, i.e. the moduli of its eigenvalues must be less +C than one. B must be an upper triangular matrix with non-negative +C entries on its main diagonal. +C +C The resulting matrix U is upper triangular. The entries on its +C main diagonal are non-negative. SCALE is an output scale factor +C set to avoid overflow in U. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether equation (1) or equation (2) is to be +C solved: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the matrix B. +C On exit, the leading N-by-N upper triangular part of this +C array contains the solution matrix U. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in U. +C 0 < SCALE <= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (6*N-6) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the generalized Sylvester equation to be solved in +C step II (see METHOD) is (nearly) singular to working +C precision; perturbed values were used to solve the +C equation (but the matrices A and E are unchanged); +C = 2: the generalized Schur form of the pencil +C A - lambda * E contains a 2-by-2 main diagonal block +C whose eigenvalues are not a pair of conjugate +C complex numbers; +C = 3: the pencil A - lambda * E is not d-stable, i.e. +C there are eigenvalues outside the open unit circle; +C = 4: the LAPACK routine DSYEVX utilized to factorize M3 +C failed to converge. This error is unlikely to occur. +C +C METHOD +C +C The method [2] used by the routine is an extension of Hammarling's +C algorithm [1] to generalized Lyapunov equations. +C +C We present the method for solving equation (1). Equation (2) can +C be treated in a similar fashion. For simplicity, assume SCALE = 1. +C +C The matrix A is an upper quasitriangular matrix, i.e. it is a +C block triangular matrix with square blocks on the main diagonal +C and the block order at most 2. We use the following partitioning +C for the matrices A, E, B and the solution matrix U +C +C ( A11 A12 ) ( E11 E12 ) +C A = ( ), E = ( ), +C ( 0 A22 ) ( 0 E22 ) +C +C ( B11 B12 ) ( U11 U12 ) +C B = ( ), U = ( ). (3) +C ( 0 B22 ) ( 0 U22 ) +C +C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or +C 2-by-2. +C +C We compute U11 and U12**T in three steps. +C +C Step I: +C +C From (1) and (3) we get the 1-by-1 or 2-by-2 equation +C +C T T T T +C A11 * U11 * U11 * A11 - E11 * U11 * U11 * E11 +C +C T +C = - B11 * B11. +C +C For brevity, details are omitted here. The technique for +C computing U11 is similar to those applied to standard Lyapunov +C equations in Hammarling's algorithm ([1], section 6). +C +C Furthermore, the auxiliary matrices M1 and M2 defined as +C follows +C +C -1 -1 +C M1 = U11 * A11 * E11 * U11 +C +C -1 -1 +C M2 = B11 * E11 * U11 +C +C are computed in a numerically reliable way. +C +C Step II: +C +C We solve for U12**T the generalized Sylvester equation +C +C T T T T +C A22 * U12 * M1 - E22 * U12 +C +C T T T T T +C = - B12 * M2 + E12 * U11 - A12 * U11 * M1. +C +C Step III: +C +C One can show that +C +C T T T T +C A22 * U22 * U22 * A22 - E22 * U22 * U22 * E22 = +C +C T T +C - B22 * B22 - y * y (4) +C +C holds, where y is defined as follows +C +C T T T T +C w = A12 * U11 + A22 * U12 +C +C T +C y = ( B12 w ) * M3EV, +C +C where M3EV is a matrix which fulfils +C +C ( I-M2*M2**T -M2*M1**T ) T +C M3 = ( ) = M3EV * M3EV . +C ( -M1*M2**T I-M1*M1**T ) +C +C M3 is positive semidefinite and its rank is equal to the size +C of U11. Therefore, a matrix M3EV can be found by solving the +C symmetric eigenvalue problem for M3 such that y consists of +C either 1 or 2 rows. +C +C If B22_tilde is the square triangular matrix arising from the +C QR-factorization +C +C ( B22_tilde ) ( B22 ) +C Q * ( ) = ( ), +C ( 0 ) ( y**T ) +C +C then +C +C T T T +C - B22 * B22 - y * y = - B22_tilde * B22_tilde. +C +C Replacing the right hand side in (4) by the term +C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov +C equation of lower dimension compared to (1). +C +C The solution U of the equation (1) can be obtained by recursive +C application of the steps I to III. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-323, 1982. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The routine requires 2*N**3 flops. Note that we count a single +C floating point arithmetic operation as one flop. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if the pencil A - lambda * E has a pair of almost reciprocal +C eigenvalues, then the Lyapunov equation will be ill-conditioned. +C Perturbed values were used to solve the equation. +C A condition estimate can be obtained from the routine SG03AD. +C When setting the error indicator INFO, the routine does not test +C for near instability in the equation but only for exact +C instability. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION HALF, MONE, ONE, TWO, ZERO + PARAMETER ( HALF = 0.5D+0, MONE = -1.0D0, ONE = 1.0D+0, + $ TWO = 2.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDB, LDE, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) +C .. Local Scalars .. + DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, UFLT, + $ X, Z + INTEGER I, INFO1, J, KB, KH, KL, LDWS, M, UIIPT, WPT, + $ YPT + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION M1(2,2), M2(2,2), M3(4,4), M3C(4,4), M3EW(4), + $ RW(32), TM(2,2), UI(2,2) + INTEGER IW(24) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLACPY, DLASET, + $ DROT, DROTG, DSCAL, DSYEVX, DSYRK, SG03BW, + $ SG03BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C +C Decode input parameter. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03BU', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + UFLT = DLAMCH( 'S' ) + SMLNUM = UFLT/EPS + BIGNUM = ONE/SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Set work space pointers and leading dimension of matrices in +C work space. +C + UIIPT = 1 + WPT = 2*N-1 + YPT = 4*N-3 + LDWS = N-1 +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the +C number of rows in this block row. +C + KH = 0 +C WHILE ( KH .LT. N ) DO + 20 IF ( KH .LT. N ) THEN + KL = KH + 1 + IF ( KL .EQ. N ) THEN + KH = N + KB = 1 + ELSE + IF ( A(KL+1,KL) .EQ. ZERO ) THEN + KH = KL + KB = 1 + ELSE + KH = KL + 1 + KB = 2 + END IF + END IF +C +C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary +C matrices M1 and M2. (For the moment the result +C U(KL:KH,KL:KH) is stored in UI). +C + IF ( KB .EQ. 1 ) THEN + DELTA1 = E(KL,KL)**2 - A(KL,KL)**2 + IF ( DELTA1 .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + DELTA1 = SQRT( DELTA1 ) + Z = TWO*ABS( B(KL,KL) )*SMLNUM + IF ( Z .GT. DELTA1 ) THEN + SCALE1 = DELTA1/Z + SCALE = SCALE1*SCALE + DO 40 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 40 CONTINUE + END IF + UI(1,1) = B(KL,KL)/DELTA1 + M1(1,1) = A(KL,KL)/E(KL,KL) + M2(1,1) = DELTA1/E(KL,KL) + ELSE +C +C If a pair of complex conjugate eigenvalues occurs, apply +C (complex) Hammarling algorithm for the 2-by-2 problem. +C + CALL SG03BX( 'D', 'N', A(KL,KL), LDA, E(KL,KL), LDE, + $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = INFO1 + RETURN + END IF + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 60 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 60 CONTINUE + END IF + END IF +C + IF ( KH .LT. N ) THEN +C +C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized +C Sylvester equation. (For the moment the result +C U(KL:KH,KH+1:N) is stored in the workspace.) +C +C Form right hand side of the Sylvester equation. +C + CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), + $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), + $ LDE, UI, 2, ONE, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, + $ ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, A(KL,KH+1), + $ LDA, TM, 2, ONE, DWORK(UIIPT), LDWS ) +C +C Solve generalized Sylvester equation. +C + CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) + CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, M1, 2, + $ E(KH+1,KH+1), LDE, TM, 2, DWORK(UIIPT), + $ LDWS, SCALE1, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 80 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 80 CONTINUE + CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) + END IF +C +C STEP III: Form the right hand side matrix +C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov +C equation to be solved during the next pass of +C the main loop. +C +C Compute auxiliary matrices M3 and Y. The factorization +C M3 = M3C * M3C**T is found by solving the symmetric +C eigenvalue problem. +C + CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) + CALL DSYRK( 'U', 'N', KB, KB, MONE, M2, 2, ONE, M3, 4 ) + CALL DGEMM( 'N', 'T', KB, KB, KB, MONE, M2, 2, M1, 2, + $ ZERO, M3(1,KB+1), 4 ) + CALL DSYRK( 'U', 'N', KB, KB, MONE, M1, 2, ONE, + $ M3(KB+1,KB+1), 4 ) + CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, + $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), + $ IW, INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 4 + RETURN + END IF + CALL DGEMM( 'T', 'N', N-KH, KB, KB, ONE, B(KL,KH+1), LDB, + $ M3C, 4, ZERO, DWORK(YPT), LDWS ) + CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, A(KL,KH+1), LDA, + $ UI, 2, ZERO, DWORK(WPT), LDWS ) + DO 100 I = 1, N-KH + CALL DGEMV( 'T', MIN( I+1, N-KH ), KB, ONE, + $ DWORK(UIIPT), LDWS, A(KH+1,KH+I), 1, ONE, + $ DWORK(WPT+I-1), LDWS ) + 100 CONTINUE + CALL DGEMM( 'N', 'N', N-KH, KB, KB, ONE, DWORK(WPT), + $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) +C +C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix +C from the QR-factorization of the (N-KH+KB)-by-(N-KH) +C matrix +C +C ( B(KH+1:N,KH+1:N) ) +C ( ) +C ( Y**T ) . +C + DO 140 J = 1, KB + DO 120 I = 1, N-KH + X = B(KH+I,KH+I) + Z = DWORK(YPT+I-1+(J-1)*LDWS) + CALL DROTG( X, Z, C, S ) + CALL DROT( N-KH-I+1, B(KH+I,KH+I), LDB, + $ DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S ) + 120 CONTINUE + 140 CONTINUE +C +C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. +C + DO 160 I = KH+1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) + 160 CONTINUE +C +C Overwrite right hand side with the part of the solution +C computed in step II. +C + DO 180 J = KL, KH + CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1, + $ B(J,KH+1), LDB ) + 180 CONTINUE + END IF +C +C Overwrite right hand side with the part of the solution +C computed in step I. +C + CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the +C number of columns in this block column. +C + KL = N + 1 +C WHILE ( KL .GT. 1 ) DO + 200 IF ( KL .GT. 1 ) THEN + KH = KL - 1 + IF ( KH .EQ. 1 ) THEN + KL = 1 + KB = 1 + ELSE + IF ( A(KH,KH-1) .EQ. ZERO ) THEN + KL = KH + KB = 1 + ELSE + KL = KH - 1 + KB = 2 + END IF + END IF +C +C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary +C matrices M1 and M2. (For the moment the result +C U(KL:KH,KL:KH) is stored in UI). +C + IF ( KB .EQ. 1 ) THEN + DELTA1 = E(KL,KL)**2 - A(KL,KL)**2 + IF ( DELTA1 .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + DELTA1 = SQRT( DELTA1 ) + Z = TWO*ABS( B(KL,KL) )*SMLNUM + IF ( Z .GT. DELTA1 ) THEN + SCALE1 = DELTA1/Z + SCALE = SCALE1*SCALE + DO 220 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 220 CONTINUE + END IF + UI(1,1) = B(KL,KL)/DELTA1 + M1(1,1) = A(KL,KL)/E(KL,KL) + M2(1,1) = DELTA1/E(KL,KL) + ELSE +C +C If a pair of complex conjugate eigenvalues occurs, apply +C (complex) Hammarling algorithm for the 2-by-2 problem. +C + CALL SG03BX( 'D', 'T', A(KL,KL), LDA, E(KL,KL), LDE, + $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = INFO1 + RETURN + END IF + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 240 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 240 CONTINUE + END IF + END IF +C + IF ( KL .GT. 1 ) THEN +C +C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized +C Sylvester equation. (For the moment the result +C U(1:KL-1,KL:KH) is stored in the workspace.) +C +C Form right hand side of the Sylvester equation. +C + CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB, + $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE, + $ UI, 2, ONE, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, + $ ZERO, TM, 2 ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA, + $ TM, 2, ONE, DWORK(UIIPT), LDWS ) +C +C Solve generalized Sylvester equation. +C + CALL DLASET( 'A', KB, KB, ZERO, MONE, TM, 2 ) + CALL SG03BW( 'T', KL-1, KB, A, LDA, M1, 2, E, LDE, TM, 2, + $ DWORK(UIIPT), LDWS, SCALE1, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 260 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 260 CONTINUE + CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) + END IF +C +C STEP III: Form the right hand side matrix +C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov +C equation to be solved during the next pass of +C the main loop. +C +C Compute auxiliary matrices M3 and Y. The factorization +C M3 = M3C * M3C**T is found by solving the symmetric +C eigenvalue problem. +C + CALL DLASET( 'U', 2*KB, 2*KB, ZERO, ONE, M3, 4 ) + CALL DSYRK( 'U', 'T', KB, KB, MONE, M2, 2, ONE, M3, 4 ) + CALL DGEMM( 'T', 'N', KB, KB, KB, MONE, M2, 2, M1, 2, + $ ZERO, M3(1,KB+1), 4 ) + CALL DSYRK( 'U', 'T', KB, KB, MONE, M1, 2, ONE, + $ M3(KB+1,KB+1), 4 ) + CALL DSYEVX( 'V', 'V', 'U', 2*KB, M3, 4, HALF, TWO, 1, 4, + $ TWO*UFLT, M, M3EW, M3C, 4, RW, 32, IW(5), + $ IW, INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = 4 + RETURN + END IF + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, B(1,KL), LDB, + $ M3C, 4, ZERO, DWORK(YPT), LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, A(1,KL), LDA, + $ UI, 2, ZERO, DWORK(WPT), LDWS ) + DO 280 I = 1, KL-1 + CALL DGEMV( 'T', MIN( KL-I+1, KL-1 ), KB, ONE, + $ DWORK(MAX( UIIPT, UIIPT+I-2 )), LDWS, + $ A(I,MAX( I-1, 1 )), LDA, ONE, + $ DWORK(WPT+I-1), LDWS ) + 280 CONTINUE + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, DWORK(WPT), + $ LDWS, M3C(KB+1,1), 4, ONE, DWORK(YPT), LDWS ) +C +C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix +C from the RQ-factorization of the (KL-1)-by-KH matrix +C +C ( ) +C ( B(1:KL-1,1:KL-1) Y ) +C ( ). +C + DO 320 J = 1, KB + DO 300 I = KL-1, 1, -1 + X = B(I,I) + Z = DWORK(YPT+I-1+(J-1)*LDWS) + CALL DROTG( X, Z, C, S ) + CALL DROT( I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1, + $ C, S ) + 300 CONTINUE + 320 CONTINUE +C +C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. +C + DO 340 I = 1, KL-1 + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( I, MONE, B(1,I), 1 ) + 340 CONTINUE +C +C Overwrite right hand side with the part of the solution +C computed in step II. +C + CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL), + $ LDB ) +C + END IF +C +C Overwrite right hand side with the part of the solution +C computed in step I. +C + CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) +C + GOTO 200 + END IF +C END WHILE 200 +C + END IF +C + RETURN +C *** Last line of SG03BU *** + END diff --git a/mex/sources/libslicot/SG03BV.f b/mex/sources/libslicot/SG03BV.f new file mode 100644 index 000000000..edce6f0dc --- /dev/null +++ b/mex/sources/libslicot/SG03BV.f @@ -0,0 +1,645 @@ + SUBROUTINE SG03BV( TRANS, N, A, LDA, E, LDE, B, LDB, SCALE, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the Cholesky factor U of the matrix X, X = U**T * U or +C X = U * U**T, which is the solution of the generalized c-stable +C continuous-time Lyapunov equation +C +C T T 2 T +C A * X * E + E * X * A = - SCALE * B * B, (1) +C +C or the transposed equation +C +C T T 2 T +C A * X * E + E * X * A = - SCALE * B * B , (2) +C +C respectively, where A, E, B, and U are real N-by-N matrices. The +C Cholesky factor U of the solution is computed without first +C finding X. The pencil A - lambda * E must be in generalized Schur +C form ( A upper quasitriangular, E upper triangular ). Moreover, it +C must be c-stable, i.e. its eigenvalues must have negative real +C parts. B must be an upper triangular matrix with non-negative +C entries on its main diagonal. +C +C The resulting matrix U is upper triangular. The entries on its +C main diagonal are non-negative. SCALE is an output scale factor +C set to avoid overflow in U. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether equation (1) or equation (2) is to be +C solved: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N upper Hessenberg part of this array +C must contain the quasitriangular matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,N) +C The leading N-by-N upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,N) +C On entry, the leading N-by-N upper triangular part of this +C array must contain the matrix B. +C On exit, the leading N-by-N upper triangular part of this +C array contains the solution matrix U. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= MAX(1,N). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in U. +C 0 < SCALE <= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (6*N-6) +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the generalized Sylvester equation to be solved in +C step II (see METHOD) is (nearly) singular to working +C precision; perturbed values were used to solve the +C equation (but the matrices A and E are unchanged); +C = 2: the generalized Schur form of the pencil +C A - lambda * E contains a 2-by-2 main diagonal block +C whose eigenvalues are not a pair of conjugate +C complex numbers; +C = 3: the pencil A - lambda * E is not stable, i.e. there +C is an eigenvalue without a negative real part. +C +C METHOD +C +C The method [2] used by the routine is an extension of Hammarling's +C algorithm [1] to generalized Lyapunov equations. +C +C We present the method for solving equation (1). Equation (2) can +C be treated in a similar fashion. For simplicity, assume SCALE = 1. +C +C The matrix A is an upper quasitriangular matrix, i.e. it is a +C block triangular matrix with square blocks on the main diagonal +C and the block order at most 2. We use the following partitioning +C for the matrices A, E, B and the solution matrix U +C +C ( A11 A12 ) ( E11 E12 ) +C A = ( ), E = ( ), +C ( 0 A22 ) ( 0 E22 ) +C +C ( B11 B12 ) ( U11 U12 ) +C B = ( ), U = ( ). (3) +C ( 0 B22 ) ( 0 U22 ) +C +C The size of the (1,1)-blocks is 1-by-1 (iff A(2,1) = 0.0) or +C 2-by-2. +C +C We compute U11 and U12**T in three steps. +C +C Step I: +C +C From (1) and (3) we get the 1-by-1 or 2-by-2 equation +C +C T T T T +C A11 * U11 * U11 * E11 + E11 * U11 * U11 * A11 +C +C T +C = - B11 * B11. +C +C For brevity, details are omitted here. The technique for +C computing U11 is similar to those applied to standard Lyapunov +C equations in Hammarling's algorithm ([1], section 6). +C +C Furthermore, the auxiliary matrices M1 and M2 defined as +C follows +C +C -1 -1 +C M1 = U11 * A11 * E11 * U11 +C +C -1 -1 +C M2 = B11 * E11 * U11 +C +C are computed in a numerically reliable way. +C +C Step II: +C +C We solve for U12**T the generalized Sylvester equation +C +C T T T T +C A22 * U12 + E22 * U12 * M1 +C +C T T T T T +C = - B12 * M2 - A12 * U11 - E12 * U11 * M1. +C +C Step III: +C +C One can show that +C +C T T T T +C A22 * U22 * U22 * E22 + E22 * U22 * U22 * A22 = +C +C T T +C - B22 * B22 - y * y (4) +C +C holds, where y is defined as follows +C +C T T T T +C w = E12 * U11 + E22 * U12 +C T T +C y = B12 - w * M2 . +C +C If B22_tilde is the square triangular matrix arising from the +C QR-factorization +C +C ( B22_tilde ) ( B22 ) +C Q * ( ) = ( ), +C ( 0 ) ( y**T ) +C +C then +C +C T T T +C - B22 * B22 - y * y = - B22_tilde * B22_tilde. +C +C Replacing the right hand side in (4) by the term +C - B22_tilde**T * B22_tilde leads to a generalized Lyapunov +C equation of lower dimension compared to (1). +C +C The solution U of the equation (1) can be obtained by recursive +C application of the steps I to III. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-323, 1982. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The routine requires 2*N**3 flops. Note that we count a single +C floating point arithmetic operation as one flop. +C +C FURTHER COMMENTS +C +C The Lyapunov equation may be very ill-conditioned. In particular, +C if the pencil A - lambda * E has a pair of almost degenerate +C eigenvalues, then the Lyapunov equation will be ill-conditioned. +C Perturbed values were used to solve the equation. +C A condition estimate can be obtained from the routine SG03AD. +C When setting the error indicator INFO, the routine does not test +C for near instability in the equation but only for exact +C instability. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, TWO, ZERO + PARAMETER ( MONE = -1.0D0, ONE = 1.0D+0, TWO = 2.0D+0, + $ ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDB, LDE, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), E(LDE,*) +C .. Local Scalars .. + DOUBLE PRECISION BIGNUM, C, DELTA1, EPS, S, SCALE1, SMLNUM, X, Z + INTEGER I, INFO1, J, KB, KH, KL, LDWS, UIIPT, WPT, YPT + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION M1(2,2), M2(2,2), TM(2,2), UI(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME + EXTERNAL DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DLABAD, DLACPY, DLASET, DROT, + $ DROTG, DSCAL, DTRMM, SG03BW, SG03BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +C .. Executable Statements .. +C +C Decode input parameter. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( N .LT. 0 ) THEN + INFO = -2 + ELSEIF ( LDA .LT. MAX( 1, N ) ) THEN + INFO = -4 + ELSEIF ( LDE .LT. MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDB .LT. MAX( 1, N ) ) THEN + INFO = -8 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03BV', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( N .EQ. 0 ) + $ RETURN +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' )/EPS + BIGNUM = ONE/SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C +C Set work space pointers and leading dimension of matrices in +C work space. +C + UIIPT = 1 + WPT = 2*N-1 + YPT = 4*N-3 + LDWS = N-1 +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Main Loop. Compute block row U(KL:KH,KL:N). KB denotes the +C number of rows in this block row. +C + KH = 0 +C WHILE ( KH .LT. N ) DO + 20 IF ( KH .LT. N ) THEN + KL = KH + 1 + IF ( KL .EQ. N ) THEN + KH = N + KB = 1 + ELSE + IF ( A(KL+1,KL) .EQ. ZERO ) THEN + KH = KL + KB = 1 + ELSE + KH = KL + 1 + KB = 2 + END IF + END IF +C +C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary +C matrices M1 and M2. (For the moment the result +C U(KL:KH,KL:KH) is stored in UI). +C + IF ( KB .EQ. 1 ) THEN + DELTA1 = -TWO*A(KL,KL)*E(KL,KL) + IF ( DELTA1 .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + DELTA1 = SQRT( DELTA1 ) + Z = TWO*ABS( B(KL,KL) )*SMLNUM + IF ( Z .GT. DELTA1 ) THEN + SCALE1 = DELTA1/Z + SCALE = SCALE1*SCALE + DO 40 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 40 CONTINUE + END IF + UI(1,1) = B(KL,KL)/DELTA1 + M1(1,1) = A(KL,KL)/E(KL,KL) + M2(1,1) = DELTA1/E(KL,KL) + ELSE +C +C If a pair of complex conjugate eigenvalues occurs, apply +C (complex) Hammarling algorithm for the 2-by-2 problem. +C + CALL SG03BX( 'C', 'N', A(KL,KL), LDA, E(KL,KL), LDE, + $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = INFO1 + RETURN + END IF + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 60 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 60 CONTINUE + END IF + END IF +C + IF ( KH .LT. N ) THEN +C +C STEP II: Compute U(KL:KH,KH+1:N) by solving a generalized +C Sylvester equation. (For the moment the result +C U(KL:KH,KH+1:N) is stored in the workspace.) +C +C Form right hand side of the Sylvester equation. +C + CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, B(KL,KH+1), + $ LDB, M2, 2, ZERO, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'T', 'T', N-KH, KB, KB, MONE, A(KL,KH+1), + $ LDA, UI, 2, ONE, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'T', 'N', KB, KB, KB, ONE, UI, 2, M1, 2, + $ ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', N-KH, KB, KB, MONE, E(KL,KH+1), + $ LDE, TM, 2, ONE, DWORK(UIIPT), LDWS ) +C +C Solve generalized Sylvester equation. +C + CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) + CALL SG03BW( 'N', N-KH, KB, A(KH+1,KH+1), LDA, TM, 2, + $ E(KH+1,KH+1), LDE, M1, 2, DWORK(UIIPT), + $ LDWS, SCALE1, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 80 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 80 CONTINUE + CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) + END IF +C +C STEP III: Form the right hand side matrix +C B(KH+1:N,KH+1:N) of the (smaller) Lyapunov +C equation to be solved during the next pass of +C the main loop. +C +C Compute auxiliary vectors (or matrices) W and Y. +C + CALL DLACPY( 'A', N-KH, KB, DWORK(UIIPT), LDWS, + $ DWORK(WPT), LDWS ) + CALL DTRMM( 'L', 'U', 'T', 'N', N-KH, KB, ONE, + $ E(KH+1,KH+1), LDE, DWORK(WPT), LDWS ) + CALL DGEMM( 'T', 'T', N-KH, KB, KB, ONE, E(KL,KH+1), + $ LDE, UI, 2, ONE, DWORK(WPT), LDWS ) + DO 100 I = KL, KH + CALL DCOPY( N-KH, B(I,KH+1), LDB, + $ DWORK(YPT+LDWS*(I-KL)), 1 ) + 100 CONTINUE + CALL DGEMM( 'N', 'T', N-KH, KB, KB, MONE, DWORK(WPT), + $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) +C +C Overwrite B(KH+1:N,KH+1:N) with the triangular matrix +C from the QR-factorization of the (N-KH+KB)-by-(N-KH) +C matrix +C +C ( B(KH+1:N,KH+1:N) ) +C ( ) +C ( Y**T ) . +C + DO 140 J = 1, KB + DO 120 I = 1, N-KH + X = B(KH+I,KH+I) + Z = DWORK(YPT+I-1+(J-1)*LDWS) + CALL DROTG( X, Z, C, S ) + CALL DROT( N-KH-I+1, B(KH+I,KH+I), LDB, + $ DWORK(YPT+I-1+(J-1)*LDWS), 1, C, S ) + 120 CONTINUE + 140 CONTINUE +C +C Make main diagonal elements of B(KH+1:N,KH+1:N) positive. +C + DO 160 I = KH+1, N + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( N-I+1, MONE, B(I,I), LDB ) + 160 CONTINUE +C +C Overwrite right hand side with the part of the solution +C computed in step II. +C + DO 180 J = KL, KH + CALL DCOPY( N-KH, DWORK(UIIPT+(J-KL)*LDWS), 1, + $ B(J,KH+1), LDB ) + 180 CONTINUE + END IF +C +C Overwrite right hand side with the part of the solution +C computed in step I. +C + CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Main Loop. Compute block column U(1:KH,KL:KH). KB denotes the +C number of columns in this block column. +C + KL = N + 1 +C WHILE ( KL .GT. 1 ) DO + 200 IF ( KL .GT. 1 ) THEN + KH = KL - 1 + IF ( KH .EQ. 1 ) THEN + KL = 1 + KB = 1 + ELSE + IF ( A(KH,KH-1) .EQ. ZERO ) THEN + KL = KH + KB = 1 + ELSE + KL = KH - 1 + KB = 2 + END IF + END IF +C +C STEP I: Compute block U(KL:KH,KL:KH) and the auxiliary +C matrices M1 and M2. (For the moment the result +C U(KL:KH,KL:KH) is stored in UI). +C + IF ( KB .EQ. 1 ) THEN + DELTA1 = -TWO*A(KL,KL)*E(KL,KL) + IF ( DELTA1 .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + DELTA1 = SQRT( DELTA1 ) + Z = TWO*ABS( B(KL,KL) )*SMLNUM + IF ( Z .GT. DELTA1 ) THEN + SCALE1 = DELTA1/Z + SCALE = SCALE1*SCALE + DO 220 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 220 CONTINUE + END IF + UI(1,1) = B(KL,KL)/DELTA1 + M1(1,1) = A(KL,KL)/E(KL,KL) + M2(1,1) = DELTA1/E(KL,KL) + ELSE +C +C If a pair of complex conjugate eigenvalues occurs, apply +C (complex) Hammarling algorithm for the 2-by-2 problem. +C + CALL SG03BX( 'C', 'T', A(KL,KL), LDA, E(KL,KL), LDE, + $ B(KL,KL), LDB, UI, 2, SCALE1, M1, 2, M2, 2, + $ INFO1 ) + IF ( INFO1 .NE. 0 ) THEN + INFO = INFO1 + RETURN + END IF + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 240 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 240 CONTINUE + END IF + END IF +C + IF ( KL .GT. 1 ) THEN +C +C STEP II: Compute U(1:KL-1,KL:KH) by solving a generalized +C Sylvester equation. (For the moment the result +C U(1:KL-1,KL:KH) is stored in the workspace.) +C +C Form right hand side of the Sylvester equation. +C + CALL DGEMM( 'N', 'T', KL-1, KB, KB, MONE, B(1,KL), LDB, + $ M2, 2, ZERO, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, A(1,KL), LDA, + $ UI, 2, ONE, DWORK(UIIPT), LDWS ) + CALL DGEMM( 'N', 'T', KB, KB, KB, ONE, UI, 2, M1, 2, + $ ZERO, TM, 2 ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, E(1,KL), LDE, + $ TM, 2, ONE, DWORK(UIIPT), LDWS ) +C +C Solve generalized Sylvester equation. +C + CALL DLASET( 'A', KB, KB, ZERO, ONE, TM, 2 ) + CALL SG03BW( 'T', KL-1, KB, A, LDA, TM, 2, E, LDE, M1, 2, + $ DWORK(UIIPT), LDWS, SCALE1, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 260 I = 1, N + CALL DSCAL( I, SCALE1, B(1,I), 1 ) + 260 CONTINUE + CALL DSCAL( 4, SCALE1, UI(1,1), 1 ) + END IF +C +C STEP III: Form the right hand side matrix +C B(1:KL-1,1:KL-1) of the (smaller) Lyapunov +C equation to be solved during the next pass of +C the main loop. +C +C Compute auxiliary vectors (or matrices) W and Y. +C + CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, + $ DWORK(WPT), LDWS ) + CALL DTRMM( 'L', 'U', 'N', 'N', KL-1, KB, ONE, E(1,1), + $ LDE, DWORK(WPT), LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, ONE, E(1,KL), LDE, + $ UI, 2, ONE, DWORK(WPT), LDWS ) + CALL DLACPY( 'A', KL-1, KB, B(1, KL), LDB, DWORK(YPT), + $ LDWS ) + CALL DGEMM( 'N', 'N', KL-1, KB, KB, MONE, DWORK(WPT), + $ LDWS, M2, 2, ONE, DWORK(YPT), LDWS ) +C +C Overwrite B(1:KL-1,1:KL-1) with the triangular matrix +C from the RQ-factorization of the (KL-1)-by-KH matrix +C +C ( ) +C ( B(1:KL-1,1:KL-1) Y ) +C ( ). +C + DO 300 J = 1, KB + DO 280 I = KL-1, 1, -1 + X = B(I,I) + Z = DWORK(YPT+I-1+(J-1)*LDWS) + CALL DROTG( X, Z, C, S ) + CALL DROT( I, B(1,I), 1, DWORK(YPT+(J-1)*LDWS), 1, + $ C, S ) + 280 CONTINUE + 300 CONTINUE +C +C Make main diagonal elements of B(1:KL-1,1:KL-1) positive. +C + DO 320 I = 1, KL-1 + IF ( B(I,I) .LT. ZERO ) + $ CALL DSCAL( I, MONE, B(1,I), 1 ) + 320 CONTINUE +C +C Overwrite right hand side with the part of the solution +C computed in step II. +C + CALL DLACPY( 'A', KL-1, KB, DWORK(UIIPT), LDWS, B(1,KL), + $ LDB ) +C + END IF +C +C Overwrite right hand side with the part of the solution +C computed in step I. +C + CALL DLACPY( 'U', KB, KB, UI, 2, B(KL,KL), LDB ) +C + GOTO 200 + END IF +C END WHILE 200 +C + END IF +C + RETURN +C *** Last line of SG03BV *** + END diff --git a/mex/sources/libslicot/SG03BW.f b/mex/sources/libslicot/SG03BW.f new file mode 100644 index 000000000..aed45369f --- /dev/null +++ b/mex/sources/libslicot/SG03BW.f @@ -0,0 +1,459 @@ + SUBROUTINE SG03BW( TRANS, M, N, A, LDA, C, LDC, E, LDE, D, LDD, X, + $ LDX, SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X the generalized Sylvester equation +C +C T T +C A * X * C + E * X * D = SCALE * Y, (1) +C +C or the transposed equation +C +C T T +C A * X * C + E * X * D = SCALE * Y, (2) +C +C where A and E are real M-by-M matrices, C and D are real N-by-N +C matrices, X and Y are real M-by-N matrices. N is either 1 or 2. +C The pencil A - lambda * E must be in generalized real Schur form +C (A upper quasitriangular, E upper triangular). SCALE is an output +C scale factor, set to avoid overflow in X. +C +C ARGUMENTS +C +C Mode Parameters +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': Solve equation (1); +C = 'T': Solve equation (2). +C +C Input/Output Parameters +C +C M (input) INTEGER +C The order of the matrices A and E. M >= 0. +C +C N (input) INTEGER +C The order of the matrices C and D. N = 1 or N = 2. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,M) +C The leading M-by-M part of this array must contain the +C upper quasitriangular matrix A. The elements below the +C upper Hessenberg part are not referenced. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,M). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading N-by-N part of this array must contain the +C matrix C. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,N). +C +C E (input) DOUBLE PRECISION array, dimension (LDE,M) +C The leading M-by-M part of this array must contain the +C upper triangular matrix E. The elements below the main +C diagonal are not referenced. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= MAX(1,M). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,N) +C The leading N-by-N part of this array must contain the +C matrix D. +C +C LDD INTEGER +C The leading dimension of the array D. LDD >= MAX(1,N). +C +C X (input/output) DOUBLE PRECISION array, dimension (LDX,N) +C On entry, the leading M-by-N part of this array must +C contain the right hand side matrix Y. +C On exit, the leading M-by-N part of this array contains +C the solution matrix X. +C +C LDX INTEGER +C The leading dimension of the array X. LDX >= MAX(1,M). +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in X. +C 0 < SCALE <= 1. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the generalized Sylvester equation is (nearly) +C singular to working precision; perturbed values +C were used to solve the equation (but the matrices +C A, C, D, and E are unchanged). +C +C METHOD +C +C The method used by the routine is based on a generalization of the +C algorithm due to Bartels and Stewart [1]. See also [2] and [3] for +C details. +C +C REFERENCES +C +C [1] Bartels, R.H., Stewart, G.W. +C Solution of the equation A X + X B = C. +C Comm. A.C.M., 15, pp. 820-826, 1972. +C +C [2] Gardiner, J.D., Laub, A.J., Amato, J.J., Moler, C.B. +C Solution of the Sylvester Matrix Equation +C A X B**T + C X D**T = E. +C A.C.M. Trans. Math. Soft., vol. 18, no. 2, pp. 223-231, 1992. +C +C [3] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C NUMERICAL ASPECTS +C +C The routine requires about 2 * N * M**2 flops. Note that we count +C a single floating point arithmetic operation as one flop. +C +C The algorithm is backward stable if the eigenvalues of the pencil +C A - lambda * E are real. Otherwise, linear systems of order at +C most 4 are involved into the computation. These systems are solved +C by Gauss elimination with complete pivoting. The loss of stability +C of the Gauss elimination with complete pivoting is rarely +C encountered in practice. +C +C FURTHER COMMENTS +C +C When near singularity is detected, perturbed values are used +C to solve the equation (but the given matrices are unchanged). +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C +C KEYWORDS +C +C Lyapunov equation +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDC, LDD, LDE, LDX, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), C(LDC,*), D(LDD,*), E(LDE,*), X(LDX,*) +C .. Local Scalars .. + DOUBLE PRECISION SCALE1 + INTEGER DIMMAT, I, INFO1, J, MA, MAI, MAJ, MB, ME + LOGICAL NOTRNS +C .. Local Arrays .. + DOUBLE PRECISION MAT(4,4), RHS(4), TM(2,2) + INTEGER PIV1(4), PIV2(4) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DSCAL, MB02UU, MB02UV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C Decode input parameters. +C + NOTRNS = LSAME( TRANS, 'N' ) +C +C Check the scalar input parameters. +C + IF ( .NOT.( NOTRNS .OR. LSAME( TRANS, 'T' ) ) ) THEN + INFO = -1 + ELSEIF ( M .LT. 0 ) THEN + INFO = -2 + ELSEIF ( N .NE. 1 .AND. N .NE. 2 ) THEN + INFO = -3 + ELSEIF ( LDA .LT. MAX( 1, M ) ) THEN + INFO = -5 + ELSEIF ( LDC .LT. MAX( 1, N ) ) THEN + INFO = -7 + ELSEIF ( LDE .LT. MAX( 1, M ) ) THEN + INFO = -9 + ELSEIF ( LDD .LT. MAX( 1, N ) ) THEN + INFO = -11 + ELSEIF ( LDX .LT. MAX( 1, M ) ) THEN + INFO = -13 + ELSE + INFO = 0 + END IF + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SG03BW', -INFO ) + RETURN + END IF +C + SCALE = ONE +C +C Quick return if possible. +C + IF ( M .EQ. 0 ) + $ RETURN +C + IF ( NOTRNS ) THEN +C +C Solve equation (1). +C +C Compute block row X(MA:ME,:). MB denotes the number of rows in +C this block row. +C + ME = 0 +C WHILE ( ME .NE. M ) DO + 20 IF ( ME .NE. M ) THEN + MA = ME + 1 + IF ( MA .EQ. M ) THEN + ME = M + MB = 1 + ELSE + IF ( A(MA+1,MA) .EQ. ZERO ) THEN + ME = MA + MB = 1 + ELSE + ME = MA + 1 + MB = 2 + END IF + END IF +C +C Assemble Kronecker product system of linear equations with +C matrix +C +C MAT = kron(C',A(MA:ME,MA:ME)') + kron(D',E(MA:ME,MA:ME)') +C +C and right hand side +C +C RHS = vec(X(MA:ME,:)). +C + IF ( N .EQ. 1 ) THEN + DIMMAT = MB + DO 60 I = 1, MB + MAI = MA + I - 1 + DO 40 J = 1, MB + MAJ = MA + J - 1 + MAT(I,J) = C(1,1)*A(MAJ,MAI) + IF ( MAJ .LE. MAI ) + $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) + 40 CONTINUE + RHS(I) = X(MAI,1) + 60 CONTINUE + ELSE + DIMMAT = 2*MB + DO 100 I = 1, MB + MAI = MA + I - 1 + DO 80 J = 1, MB + MAJ = MA + J - 1 + MAT(I,J) = C(1,1)*A(MAJ,MAI) + MAT(MB+I,J) = C(1,2)*A(MAJ,MAI) + MAT(I,MB+J) = C(2,1)*A(MAJ,MAI) + MAT(MB+I,MB+J) = C(2,2)*A(MAJ,MAI) + IF ( MAJ .LE. MAI ) THEN + MAT(I,J) = MAT(I,J) + D(1,1)*E(MAJ,MAI) + MAT(MB+I,J) = MAT(MB+I,J) + D(1,2)*E(MAJ,MAI) + MAT(I,MB+J) = MAT(I,MB+J) + D(2,1)*E(MAJ,MAI) + MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + + $ D(2,2)*E(MAJ,MAI) + END IF + 80 CONTINUE + RHS(I) = X(MAI,1) + RHS(MB+I) = X(MAI,2) + 100 CONTINUE + END IF +C +C Solve the system of linear equations. +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 120 I = 1, N + CALL DSCAL( M, SCALE1, X(1,I), 1 ) + 120 CONTINUE + END IF +C + IF ( N .EQ. 1 ) THEN + DO 140 I = 1, MB + MAI = MA + I - 1 + X(MAI,1) = RHS(I) + 140 CONTINUE + ELSE + DO 160 I = 1, MB + MAI = MA + I - 1 + X(MAI,1) = RHS(I) + X(MAI,2) = RHS(MB+I) + 160 CONTINUE + END IF +C +C Update right hand sides. +C +C X(ME+1:M,:) = X(ME+1:M,:) - A(MA:ME,ME+1:M)'*X(MA:ME,:)*C +C +C X(ME+1:M,:) = X(ME+1:M,:) - E(MA:ME,ME+1:M)'*X(MA:ME,:)*D +C + IF ( ME .LT. M ) THEN + CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, C, + $ LDC, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, A(MA,ME+1), + $ LDA, TM, 2, ONE, X(ME+1,1), LDX ) + CALL DGEMM( 'N', 'N', MB, N, N, ONE, X(MA,1), LDX, D, + $ LDD, ZERO, TM, 2 ) + CALL DGEMM( 'T', 'N', M-ME, N, MB, MONE, E(MA,ME+1), LDE, + $ TM, 2, ONE, X(ME+1,1), LDX ) + END IF +C + GOTO 20 + END IF +C END WHILE 20 +C + ELSE +C +C Solve equation (2). +C +C Compute block row X(MA:ME,:). MB denotes the number of rows in +C this block row. +C + MA = M + 1 +C WHILE ( MA .NE. 1 ) DO + 180 IF ( MA .NE. 1 ) THEN + ME = MA - 1 + IF ( ME .EQ. 1 ) THEN + MA = 1 + MB = 1 + ELSE + IF ( A(ME,ME-1) .EQ. ZERO ) THEN + MA = ME + MB = 1 + ELSE + MA = ME - 1 + MB = 2 + END IF + END IF +C +C Assemble Kronecker product system of linear equations with +C matrix +C +C MAT = kron(C,A(MA:ME,MA:ME)) + kron(D,E(MA:ME,MA:ME)) +C +C and right hand side +C +C RHS = vec(X(MA:ME,:)). +C + IF ( N .EQ. 1 ) THEN + DIMMAT = MB + DO 220 I = 1, MB + MAI = MA + I - 1 + DO 200 J = 1, MB + MAJ = MA + J - 1 + MAT(I,J) = C(1,1)*A(MAI,MAJ) + IF ( MAJ .GE. MAI ) + $ MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) + 200 CONTINUE + RHS(I) = X(MAI,1) + 220 CONTINUE + ELSE + DIMMAT = 2*MB + DO 260 I = 1, MB + MAI = MA + I - 1 + DO 240 J = 1, MB + MAJ = MA + J - 1 + MAT(I,J) = C(1,1)*A(MAI,MAJ) + MAT(MB+I,J) = C(2,1)*A(MAI,MAJ) + MAT(I,MB+J) = C(1,2)*A(MAI,MAJ) + MAT(MB+I,MB+J) = C(2,2)*A(MAI,MAJ) + IF ( MAJ .GE. MAI ) THEN + MAT(I,J) = MAT(I,J) + D(1,1)*E(MAI,MAJ) + MAT(MB+I,J) = MAT(MB+I,J) + D(2,1)*E(MAI,MAJ) + MAT(I,MB+J) = MAT(I,MB+J) + D(1,2)*E(MAI,MAJ) + MAT(MB+I,MB+J) = MAT(MB+I,MB+J) + + $ D(2,2)*E(MAI,MAJ) + END IF + 240 CONTINUE + RHS(I) = X(MAI,1) + RHS(MB+I) = X(MAI,2) + 260 CONTINUE + END IF +C +C Solve the system of linear equations. +C + CALL MB02UV( DIMMAT, MAT, 4, PIV1, PIV2, INFO1 ) + IF ( INFO1 .NE. 0 ) + $ INFO = 1 + CALL MB02UU( DIMMAT, MAT, 4, RHS, PIV1, PIV2, SCALE1 ) + IF ( SCALE1 .NE. ONE ) THEN + SCALE = SCALE1*SCALE + DO 280 I = 1, N + CALL DSCAL( M, SCALE1, X(1,I), 1 ) + 280 CONTINUE + END IF +C + IF ( N .EQ. 1 ) THEN + DO 300 I = 1, MB + MAI = MA + I - 1 + X(MAI,1) = RHS(I) + 300 CONTINUE + ELSE + DO 320 I = 1, MB + MAI = MA + I - 1 + X(MAI,1) = RHS(I) + X(MAI,2) = RHS(MB+I) + 320 CONTINUE + END IF +C +C Update right hand sides. +C +C X(1:MA-1,:) = X(1:MA-1,:) - A(1:MA-1,MA:ME)*X(MA:ME,:)*C' +C +C X(1:MA-1,:) = X(1:MA-1,:) - E(1:MA-1,MA:ME)*X(MA:ME,:)*D' +C + IF ( MA .GT. 1 ) THEN + CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, C, + $ LDC, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, A(1,MA), LDA, + $ TM, 2, ONE, X, LDX ) + CALL DGEMM( 'N', 'T', MB, N, N, ONE, X(MA,1), LDX, D, + $ LDD, ZERO, TM, 2 ) + CALL DGEMM( 'N', 'N', MA-1, N, MB, MONE, E(1,MA), LDE, + $ TM, 2, ONE, X, LDX ) + END IF +C + GOTO 180 + END IF +C END WHILE 180 +C + END IF +C + RETURN +C *** Last line of SG03BW *** + END diff --git a/mex/sources/libslicot/SG03BX.f b/mex/sources/libslicot/SG03BX.f new file mode 100644 index 000000000..651716cd9 --- /dev/null +++ b/mex/sources/libslicot/SG03BX.f @@ -0,0 +1,764 @@ + SUBROUTINE SG03BX( DICO, TRANS, A, LDA, E, LDE, B, LDB, U, LDU, + $ SCALE, M1, LDM1, M2, LDM2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To solve for X = op(U)**T * op(U) either the generalized c-stable +C continuous-time Lyapunov equation +C +C T T +C op(A) * X * op(E) + op(E) * X * op(A) +C +C 2 T +C = - SCALE * op(B) * op(B), (1) +C +C or the generalized d-stable discrete-time Lyapunov equation +C +C T T +C op(A) * X * op(A) - op(E) * X * op(E) +C +C 2 T +C = - SCALE * op(B) * op(B), (2) +C +C where op(K) is either K or K**T for K = A, B, E, U. The Cholesky +C factor U of the solution is computed without first finding X. +C +C Furthermore, the auxiliary matrices +C +C -1 -1 +C M1 := op(U) * op(A) * op(E) * op(U) +C +C -1 -1 +C M2 := op(B) * op(E) * op(U) +C +C are computed in a numerically reliable way. +C +C The matrices A, B, E, M1, M2, and U are real 2-by-2 matrices. The +C pencil A - lambda * E must have a pair of complex conjugate +C eigenvalues. The eigenvalues must be in the open right half plane +C (in the continuous-time case) or inside the unit circle (in the +C discrete-time case). +C +C The resulting matrix U is upper triangular. The entries on its +C main diagonal are non-negative. SCALE is an output scale factor +C set to avoid overflow in U. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies whether the continuous-time or the discrete-time +C equation is to be solved: +C = 'C': Solve continuous-time equation (1); +C = 'D': Solve discrete-time equation (2). +C +C TRANS CHARACTER*1 +C Specifies whether the transposed equation is to be solved +C or not: +C = 'N': op(K) = K, K = A, B, E, U; +C = 'T': op(K) = K**T, K = A, B, E, U. +C +C Input/Output Parameters +C +C A (input) DOUBLE PRECISION array, dimension (LDA,2) +C The leading 2-by-2 part of this array must contain the +C matrix A. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= 2. +C +C E (input) DOUBLE PRECISION array, dimension (LDE,2) +C The leading 2-by-2 upper triangular part of this array +C must contain the matrix E. +C +C LDE INTEGER +C The leading dimension of the array E. LDE >= 2. +C +C B (input) DOUBLE PRECISION array, dimension (LDB,2) +C The leading 2-by-2 upper triangular part of this array +C must contain the matrix B. +C +C LDB INTEGER +C The leading dimension of the array B. LDB >= 2. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,2) +C The leading 2-by-2 part of this array contains the upper +C triangular matrix U. +C +C LDU INTEGER +C The leading dimension of the array U. LDU >= 2. +C +C SCALE (output) DOUBLE PRECISION +C The scale factor set to avoid overflow in U. +C 0 < SCALE <= 1. +C +C M1 (output) DOUBLE PRECISION array, dimension (LDM1,2) +C The leading 2-by-2 part of this array contains the +C matrix M1. +C +C LDM1 INTEGER +C The leading dimension of the array M1. LDM1 >= 2. +C +C M2 (output) DOUBLE PRECISION array, dimension (LDM2,2) +C The leading 2-by-2 part of this array contains the +C matrix M2. +C +C LDM2 INTEGER +C The leading dimension of the array M2. LDM2 >= 2. +C +C Error indicator +C +C INFO INTEGER +C = 0: successful exit; +C = 2: the eigenvalues of the pencil A - lambda * E are not +C a pair of complex conjugate numbers; +C = 3: the eigenvalues of the pencil A - lambda * E are +C not in the open right half plane (in the continuous- +C time case) or inside the unit circle (in the +C discrete-time case). +C +C METHOD +C +C The method used by the routine is based on a generalization of the +C method due to Hammarling ([1], section 6) for Lyapunov equations +C of order 2. A more detailed description is given in [2]. +C +C REFERENCES +C +C [1] Hammarling, S.J. +C Numerical solution of the stable, non-negative definite +C Lyapunov equation. +C IMA J. Num. Anal., 2, pp. 303-323, 1982. +C +C [2] Penzl, T. +C Numerical solution of generalized Lyapunov equations. +C Advances in Comp. Math., vol. 8, pp. 33-48, 1998. +C +C FURTHER COMMENTS +C +C If the solution matrix U is singular, the matrices M1 and M2 are +C properly set (see [1], equation (6.21)). +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C Dec. 1998 (V. Sima). +C July 2003 (V. Sima; suggested by Klaus Schnepper). +C Oct. 2003 (A. Varga). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION MONE, ONE, TWO, ZERO + PARAMETER ( MONE = -1.0D+0, ONE = 1.0D+0, TWO = 2.0D+0, + $ ZERO = 0.0D+0) +C .. Scalar Arguments .. + CHARACTER DICO, TRANS + DOUBLE PRECISION SCALE + INTEGER INFO, LDA, LDB, LDE, LDM1, LDM2, LDU +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), E(LDE,*), M1(LDM1,*), + $ M2(LDM2,*), U(LDU,*) +C .. Local Scalars .. + DOUBLE PRECISION ALPHA, B11, B12I, B12R, B22, BETAI, BETAR, + $ BIGNUM, CI, CR, EPS, L, LAMI, LAMR, SCALE1, + $ SCALE2, SI, SMLNUM, SR, T, V, W, XR, XI, YR, YI + LOGICAL ISCONT, ISTRNS +C .. Local Arrays .. + DOUBLE PRECISION AA(2,2), AI(2,2), AR(2,2), BB(2,2), BI(2,2), + $ BR(2,2), EE(2,2), EI(2,2), ER(2,2), M1I(2,2), + $ M1R(2,2), M2I(2,2), M2R(2,2), QBI(2,2), + $ QBR(2,2), QI(2,2), QR(2,2), QUI(2,2), QUR(2,2), + $ TI(2,2), TR(2,2), UI(2,2), UR(2,2), ZI(2,2), + $ ZR(2,2) +C .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2 + LOGICAL LSAME + EXTERNAL DLAMCH, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLABAD, DLADIV, DLAG2, + $ SG03BY +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +C +C Decode input parameters. +C + ISTRNS = LSAME( TRANS, 'T' ) + ISCONT = LSAME( DICO, 'C' ) +C +C Do not check input parameters for errors. +C +C Set constants to control overflow. +C + EPS = DLAMCH( 'P' ) + SMLNUM = DLAMCH( 'S' )/EPS + BIGNUM = ONE/SMLNUM + CALL DLABAD( SMLNUM, BIGNUM ) +C + INFO = 0 + SCALE = ONE +C +C Make copies of A, E, and B. +C + AA(1,1) = A(1,1) + AA(2,1) = A(2,1) + AA(1,2) = A(1,2) + AA(2,2) = A(2,2) + EE(1,1) = E(1,1) + EE(2,1) = ZERO + EE(1,2) = E(1,2) + EE(2,2) = E(2,2) + BB(1,1) = B(1,1) + BB(2,1) = ZERO + BB(1,2) = B(1,2) + BB(2,2) = B(2,2) +C +C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be +C solved, transpose the matrices A, E, B with respect to the +C anti-diagonal. This results in a non-transposed equation. +C + IF ( ISTRNS ) THEN + V = AA(1,1) + AA(1,1) = AA(2,2) + AA(2,2) = V + V = EE(1,1) + EE(1,1) = EE(2,2) + EE(2,2) = V + V = BB(1,1) + BB(1,1) = BB(2,2) + BB(2,2) = V + END IF +C +C Perform QZ-step to transform the pencil A - lambda * E to +C generalized Schur form. The main diagonal of the Schur factor of E +C is real and positive. +C +C Compute eigenvalues (LAMR + LAMI * I, LAMR - LAMI * I). +C + T = MAX( EPS*MAX( ABS( EE(1,1) ), ABS( EE(1,2) ), + $ ABS( EE(2,2) ) ), SMLNUM ) + IF ( MIN( ABS( EE(1,1) ), ABS( EE(2,2) ) ) .LT. T ) THEN + INFO = 3 + RETURN + END IF + CALL DLAG2( AA, 2, EE, 2, SMLNUM*EPS, SCALE1, SCALE2, LAMR, + $ W, LAMI ) + IF (LAMI .LE. ZERO) THEN + INFO = 2 + RETURN + END IF +C +C Compute right orthogonal transformation matrix Q. +C + CALL SG03BY( SCALE1*AA(1,1) - EE(1,1)*LAMR, -EE(1,1)*LAMI, + $ SCALE1*AA(2,1), ZERO, CR, CI, SR, SI, L ) + QR(1,1) = CR + QR(1,2) = SR + QR(2,1) = -SR + QR(2,2) = CR + QI(1,1) = -CI + QI(1,2) = -SI + QI(2,1) = -SI + QI(2,2) = CI +C +C A := Q * A +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QR, 2, AA, 2, ZERO, AR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QI, 2, AA, 2, ZERO, AI, 2 ) +C +C E := Q * E +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QR, 2, EE, 2, ZERO, ER, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QI, 2, EE, 2, ZERO, EI, 2 ) +C +C Compute left orthogonal transformation matrix Z. +C + CALL SG03BY( ER(2,2), EI(2,2), ER(2,1), EI(2,1), CR, CI, SR, SI, + $ L ) + ZR(1,1) = CR + ZR(1,2) = SR + ZR(2,1) = -SR + ZR(2,2) = CR + ZI(1,1) = CI + ZI(1,2) = -SI + ZI(2,1) = -SI + ZI(2,2) = -CI +C +C E := E * Z +C + CALL DGEMV( 'T', 2, 2, ONE, ZR, 2, ER, 2, ZERO, TR, 2 ) + CALL DGEMV( 'T', 2, 2, MONE, ZI, 2, EI, 2, ONE, TR, 2 ) + CALL DGEMV( 'T', 2, 2, ONE, ZI, 2, ER, 2, ZERO, TI, 2 ) + CALL DGEMV( 'T', 2, 2, ONE, ZR, 2, EI, 2, ONE, TI, 2 ) + CALL DCOPY( 2, TR, 2, ER, 2 ) + CALL DCOPY( 2, TI, 2, EI, 2 ) + ER(2,1) = ZERO + ER(2,2) = L + EI(2,1) = ZERO + EI(2,2) = ZERO +C +C Make main diagonal entries of E real and positive. +C (Note: Z and E are altered.) +C + V = DLAPY2( ER(1,1), EI(1,1) ) + CALL DLADIV( V, ZERO, ER(1,1), EI(1,1), XR, XI ) + ER(1,1) = V + EI(1,1) = ZERO + YR = ZR(1,1) + YI = ZI(1,1) + ZR(1,1) = XR*YR - XI*YI + ZI(1,1) = XR*YI + XI*YR + YR = ZR(2,1) + YI = ZI(2,1) + ZR(2,1) = XR*YR - XI*YI + ZI(2,1) = XR*YI + XI*YR +C +C A := A * Z +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AR, 2, ZR, 2, ZERO, TR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, AI, 2, ZI, 2, ONE, TR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AR, 2, ZI, 2, ZERO, TI, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, AI, 2, ZR, 2, ONE, TI, 2 ) + CALL DCOPY( 4, TR, 1, AR, 1 ) + CALL DCOPY( 4, TI, 1, AI, 1 ) +C +C End of QZ-step. +C +C B := B * Z +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, BB, 2, ZR, 2, ZERO, BR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, BB, 2, ZI, 2, ZERO, BI, 2 ) +C +C Overwrite B with the upper triangular matrix of its +C QR-factorization. The elements on the main diagonal are real +C and non-negative. +C + CALL SG03BY( BR(1,1), BI(1,1), BR(2,1), BI(2,1), CR, CI, SR, SI, + $ L ) + QBR(1,1) = CR + QBR(1,2) = SR + QBR(2,1) = -SR + QBR(2,2) = CR + QBI(1,1) = -CI + QBI(1,2) = -SI + QBI(2,1) = -SI + QBI(2,2) = CI + CALL DGEMV( 'N', 2, 2, ONE, QBR, 2, BR(1,2), 1, ZERO, TR, 1 ) + CALL DGEMV( 'N', 2, 2, MONE, QBI, 2, BI(1,2), 1, ONE, TR, 1 ) + CALL DGEMV( 'N', 2, 2, ONE, QBI, 2, BR(1,2), 1, ZERO, TI, 1 ) + CALL DGEMV( 'N', 2, 2, ONE, QBR, 2, BI(1,2), 1, ONE, TI, 1 ) + CALL DCOPY( 2, TR, 1, BR(1,2), 1 ) + CALL DCOPY( 2, TI, 1, BI(1,2), 1 ) + BR(1,1) = L + BR(2,1) = ZERO + BI(1,1) = ZERO + BI(2,1) = ZERO + V = DLAPY2( BR(2,2), BI(2,2) ) + IF ( V .GE. MAX( EPS*MAX( BR(1,1), DLAPY2( BR(1,2), BI(1,2) ) ), + $ SMLNUM ) ) THEN + CALL DLADIV( V, ZERO, BR(2,2), BI(2,2), XR, XI ) + BR(2,2) = V + YR = QBR(2,1) + YI = QBI(2,1) + QBR(2,1) = XR*YR - XI*YI + QBI(2,1) = XR*YI + XI*YR + YR = QBR(2,2) + YI = QBI(2,2) + QBR(2,2) = XR*YR - XI*YI + QBI(2,2) = XR*YI + XI*YR + ELSE + BR(2,2) = ZERO + END IF + BI(2,2) = ZERO +C +C Compute the Cholesky factor of the solution of the reduced +C equation. The solution may be scaled to avoid overflow. +C + IF ( ISCONT ) THEN +C +C Continuous-time equation. +C +C Step I: Compute U(1,1). Set U(2,1) = 0. +C + V = -TWO*( AR(1,1)*ER(1,1) + AI(1,1)*EI(1,1) ) + IF ( V .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + V = SQRT( V ) + T = TWO*ABS( BR(1,1) )*SMLNUM + IF ( T .GT. V ) THEN + SCALE1 = V/T + SCALE = SCALE1*SCALE + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + END IF + UR(1,1) = BR(1,1)/V + UI(1,1) = ZERO + UR(2,1) = ZERO + UI(2,1) = ZERO +C +C Step II: Compute U(1,2). +C + T = MAX( EPS*MAX( BR(2,2), DLAPY2( BR(1,2), BI(1,2) ) ), + $ SMLNUM ) + IF ( ABS( BR(1,1) ) .LT. T ) THEN + UR(1,2) = ZERO + UI(1,2) = ZERO + ELSE + XR = AR(1,1)*ER(1,2) + AI(1,1)*EI(1,2) + XI = AI(1,1)*ER(1,2) - AR(1,1)*EI(1,2) + XR = XR + AR(1,2)*ER(1,1) + AI(1,2)*EI(1,1) + XI = XI - AI(1,2)*ER(1,1) + AR(1,2)*EI(1,1) + XR = -BR(1,2)*V - XR*UR(1,1) + XI = BI(1,2)*V - XI*UR(1,1) + YR = AR(2,2)*ER(1,1) + AI(2,2)*EI(1,1) + YI = -AI(2,2)*ER(1,1) + AR(2,2)*EI(1,1) + YR = YR + ER(2,2)*AR(1,1) + EI(2,2)*AI(1,1) + YI = YI - EI(2,2)*AR(1,1) + ER(2,2)*AI(1,1) + T = TWO*DLAPY2( XR, XI )*SMLNUM + IF ( T .GT. DLAPY2( YR, YI ) ) THEN + SCALE1 = DLAPY2( YR, YI )/T + SCALE = SCALE1*SCALE + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + UR(1,1) = SCALE1*UR(1,1) + XR = SCALE1*XR + XI = SCALE1*XI + END IF + CALL DLADIV( XR, XI, YR, YI, UR(1,2), UI(1,2) ) + UI(1,2) = -UI(1,2) + END IF +C +C Step III: Compute U(2,2). +C + XR = ( ER(1,2)*UR(1,1) + ER(2,2)*UR(1,2) - EI(2,2)*UI(1,2) )*V + XI = (-EI(1,2)*UR(1,1) - ER(2,2)*UI(1,2) - EI(2,2)*UR(1,2) )*V + T = TWO*DLAPY2( XR, XI )*SMLNUM + IF ( T .GT. DLAPY2( ER(1,1), EI(1,1) ) ) THEN + SCALE1 = DLAPY2( ER(1,1), EI(1,1) )/T + SCALE = SCALE1*SCALE + UR(1,1) = SCALE1*UR(1,1) + UR(1,2) = SCALE1*UR(1,2) + UI(1,2) = SCALE1*UI(1,2) + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + XR = SCALE1*XR + XI = SCALE1*XI + END IF + CALL DLADIV( XR, XI, ER(1,1), -EI(1,1), YR, YI ) + YR = BR(1,2) - YR + YI = -BI(1,2) - YI + V = -TWO*( AR(2,2)*ER(2,2) + AI(2,2)*EI(2,2) ) + IF ( V .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + V = SQRT( V ) + W = DLAPY2( DLAPY2( BR(2,2), BI(2,2) ), DLAPY2( YR, YI ) ) + T = TWO*W*SMLNUM + IF ( T .GT. V ) THEN + SCALE1 = V/T + SCALE = SCALE1*SCALE + UR(1,1) = SCALE1*UR(1,1) + UR(1,2) = SCALE1*UR(1,2) + UI(1,2) = SCALE1*UI(1,2) + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + W = SCALE1*W + END IF + UR(2,2) = W/V + UI(2,2) = ZERO +C +C Compute matrices M1 and M2 for the reduced equation. +C + M1R(2,1) = ZERO + M1I(2,1) = ZERO + M2R(2,1) = ZERO + M2I(2,1) = ZERO + CALL DLADIV( AR(1,1), AI(1,1), ER(1,1), EI(1,1), BETAR, BETAI ) + M1R(1,1) = BETAR + M1I(1,1) = BETAI + M1R(2,2) = BETAR + M1I(2,2) = -BETAI + ALPHA = SQRT( -TWO*BETAR ) + M2R(1,1) = ALPHA + M2I(1,1) = ZERO + V = ER(1,1)*ER(2,2) + XR = ( -BR(1,1)*ER(1,2) + ER(1,1)*BR(1,2) )/V + XI = ( -BR(1,1)*EI(1,2) + ER(1,1)*BI(1,2) )/V + YR = XR - ALPHA*UR(1,2) + YI = -XI + ALPHA*UI(1,2) + IF ( ( YR.NE.ZERO ) .OR. ( YI.NE.ZERO ) ) THEN + M2R(1,2) = YR/UR(2,2) + M2I(1,2) = -YI/UR(2,2) + M2R(2,2) = BR(2,2)/( ER(2,2)*UR(2,2) ) + M2I(2,2) = ZERO + M1R(1,2) = -ALPHA*M2R(1,2) + M1I(1,2) = -ALPHA*M2I(1,2) + ELSE + M2R(1,2) = ZERO + M2I(1,2) = ZERO + M2R(2,2) = ALPHA + M2I(2,2) = ZERO + M1R(1,2) = ZERO + M1I(1,2) = ZERO + END IF + ELSE +C +C Discrete-time equation. +C +C Step I: Compute U(1,1). Set U(2,1) = 0. +C + V = ER(1,1)**2 + EI(1,1)**2 - AR(1,1)**2 - AI(1,1)**2 + IF ( V .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + V = SQRT( V ) + T = TWO*ABS( BR(1,1) )*SMLNUM + IF ( T .GT. V ) THEN + SCALE1 = V/T + SCALE = SCALE1*SCALE + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + END IF + UR(1,1) = BR(1,1)/V + UI(1,1) = ZERO + UR(2,1) = ZERO + UI(2,1) = ZERO +C +C Step II: Compute U(1,2). +C + T = MAX( EPS*MAX( BR(2,2), DLAPY2( BR(1,2), BI(1,2) ) ), + $ SMLNUM ) + IF ( ABS( BR(1,1) ) .LT. T ) THEN + UR(1,2) = ZERO + UI(1,2) = ZERO + ELSE + XR = AR(1,1)*AR(1,2) + AI(1,1)*AI(1,2) + XI = AI(1,1)*AR(1,2) - AR(1,1)*AI(1,2) + XR = XR - ER(1,2)*ER(1,1) - EI(1,2)*EI(1,1) + XI = XI + EI(1,2)*ER(1,1) - ER(1,2)*EI(1,1) + XR = -BR(1,2)*V - XR*UR(1,1) + XI = BI(1,2)*V - XI*UR(1,1) + YR = AR(2,2)*AR(1,1) + AI(2,2)*AI(1,1) + YI = -AI(2,2)*AR(1,1) + AR(2,2)*AI(1,1) + YR = YR - ER(2,2)*ER(1,1) - EI(2,2)*EI(1,1) + YI = YI + EI(2,2)*ER(1,1) - ER(2,2)*EI(1,1) + T = TWO*DLAPY2( XR, XI )*SMLNUM + IF ( T .GT. DLAPY2( YR, YI ) ) THEN + SCALE1 = DLAPY2( YR, YI )/T + SCALE = SCALE1*SCALE + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + UR(1,1) = SCALE1*UR(1,1) + XR = SCALE1*XR + XI = SCALE1*XI + END IF + CALL DLADIV( XR, XI, YR, YI, UR(1,2), UI(1,2) ) + UI(1,2) = -UI(1,2) + END IF +C +C Step III: Compute U(2,2). +C + XR = ER(1,2)*UR(1,1) + ER(2,2)*UR(1,2) - EI(2,2)*UI(1,2) + XI = -EI(1,2)*UR(1,1) - ER(2,2)*UI(1,2) - EI(2,2)*UR(1,2) + YR = AR(1,2)*UR(1,1) + AR(2,2)*UR(1,2) - AI(2,2)*UI(1,2) + YI = -AI(1,2)*UR(1,1) - AR(2,2)*UI(1,2) - AI(2,2)*UR(1,2) + V = ER(2,2)**2 + EI(2,2)**2 - AR(2,2)**2 - AI(2,2)**2 + IF ( V .LE. ZERO ) THEN + INFO = 3 + RETURN + END IF + V = SQRT( V ) + T = MAX( ABS( BR(2,2) ), ABS( BR(1,2) ), ABS( BI(1,2) ), + $ ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI) ) + IF ( T .LE. SMLNUM ) T = ONE + W = ( BR(2,2)/T )**2 + ( BR(1,2)/T )**2 + ( BI(1,2)/T )**2 - + $ ( XR/T )**2 - ( XI/T )**2 + ( YR/T )**2 + ( YI/T )**2 + IF ( W .LT. ZERO ) THEN + INFO = 3 + RETURN + END IF + W = T*SQRT( W ) + T = TWO*W*SMLNUM + IF ( T .GT. V ) THEN + SCALE1 = V/T + SCALE = SCALE1*SCALE + UR(1,1) = SCALE1*UR(1,1) + UR(1,2) = SCALE1*UR(1,2) + UI(1,2) = SCALE1*UI(1,2) + BR(1,1) = SCALE1*BR(1,1) + BR(1,2) = SCALE1*BR(1,2) + BI(1,2) = SCALE1*BI(1,2) + BR(2,2) = SCALE1*BR(2,2) + W = SCALE1*W + END IF + UR(2,2) = W/V + UI(2,2) = ZERO +C +C Compute matrices M1 and M2 for the reduced equation. +C + B11 = BR(1,1)/ER(1,1) + T = ER(1,1)*ER(2,2) + B12R = ( ER(1,1)*BR(1,2) - BR(1,1)*ER(1,2) )/T + B12I = ( ER(1,1)*BI(1,2) - BR(1,1)*EI(1,2) )/T + B22 = BR(2,2)/ER(2,2) + M1R(2,1) = ZERO + M1I(2,1) = ZERO + M2R(2,1) = ZERO + M2I(2,1) = ZERO + CALL DLADIV( AR(1,1), AI(1,1), ER(1,1), EI(1,1), BETAR, BETAI ) + M1R(1,1) = BETAR + M1I(1,1) = BETAI + M1R(2,2) = BETAR + M1I(2,2) = -BETAI + V = DLAPY2( BETAR, BETAI ) + ALPHA = SQRT( ( ONE - V )*( ONE + V ) ) + M2R(1,1) = ALPHA + M2I(1,1) = ZERO + XR = ( AI(1,1)*EI(1,2) - AR(1,1)*ER(1,2) )/T + AR(1,2)/ER(2,2) + XI = ( AR(1,1)*EI(1,2) + AI(1,1)*ER(1,2) )/T - AI(1,2)/ER(2,2) + XR = -TWO*BETAI*B12I - B11*XR + XI = -TWO*BETAI*B12R - B11*XI + V = ONE + ( BETAI - BETAR )*( BETAI + BETAR ) + W = -TWO*BETAI*BETAR + CALL DLADIV( XR, XI, V, W, YR, YI ) + IF ( ( YR.NE.ZERO ) .OR. ( YI.NE.ZERO ) ) THEN + M2R(1,2) = ( YR*BETAR - YI*BETAI )/UR(2,2) + M2I(1,2) = -( YI*BETAR + YR*BETAI )/UR(2,2) + M2R(2,2) = B22/UR(2,2) + M2I(2,2) = ZERO + M1R(1,2) = -ALPHA*YR/UR(2,2) + M1I(1,2) = ALPHA*YI/UR(2,2) + ELSE + M2R(1,2) = ZERO + M2I(1,2) = ZERO + M2R(2,2) = ALPHA + M2I(2,2) = ZERO + M1R(1,2) = ZERO + M1I(1,2) = ZERO + END IF + END IF +C +C Transform U back: U := U * Q. +C (Note: Z is used as workspace.) +C + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UR, 2, QR, 2, ZERO, ZR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, UI, 2, QI, 2, ONE, ZR, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UR, 2, QI, 2, ZERO, ZI, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, UI, 2, QR, 2, ONE, ZI, 2 ) +C +C Overwrite U with the upper triangular matrix of its +C QR-factorization. The elements on the main diagonal are real +C and non-negative. +C + CALL SG03BY( ZR(1,1), ZI(1,1), ZR(2,1), ZI(2,1), CR, CI, SR, SI, + $ L ) + QUR(1,1) = CR + QUR(1,2) = SR + QUR(2,1) = -SR + QUR(2,2) = CR + QUI(1,1) = -CI + QUI(1,2) = -SI + QUI(2,1) = -SI + QUI(2,2) = CI + CALL DGEMV( 'N', 2, 2, ONE, QUR, 2, ZR(1,2), 1, ZERO, U(1,2), 1) + CALL DGEMV( 'N', 2, 2, MONE, QUI, 2, ZI(1,2), 1, ONE, U(1,2), 1) + CALL DGEMV( 'N', 2, 2, ONE, QUI, 2, ZR(1,2), 1, ZERO, UI(1,2), 1) + CALL DGEMV( 'N', 2, 2, ONE, QUR, 2, ZI(1,2), 1, ONE, UI(1,2), 1) + U(1,1) = L + U(2,1) = ZERO + V = DLAPY2( U(2,2), UI(2,2) ) + IF ( V .NE. ZERO ) THEN + CALL DLADIV( V, ZERO, U(2,2), UI(2,2), XR, XI ) + YR = QUR(2,1) + YI = QUI(2,1) + QUR(2,1) = XR*YR - XI*YI + QUI(2,1) = XR*YI + XI*YR + YR = QUR(2,2) + YI = QUI(2,2) + QUR(2,2) = XR*YR - XI*YI + QUI(2,2) = XR*YI + XI*YR + END IF + U(2,2) = V +C +C Transform the matrices M1 and M2 back. +C +C M1 := QU * M1 * QU**H +C M2 := QB**H * M2 * QU**H +C + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1R, 2, QUR, 2, ZERO, TR, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1I, 2, QUI, 2, ONE, TR, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, MONE, M1R, 2, QUI, 2, ZERO, TI, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M1I, 2, QUR, 2, ONE, TI, 2 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, ONE, QUR, 2, TR, 2, ZERO, M1, + $ LDM1 ) + CALL DGEMM( 'N', 'N', 2, 2, 2, MONE, QUI, 2, TI, 2, ONE, M1, + $ LDM1 ) +C + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2R, 2, QUR, 2, ZERO, TR, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2I, 2, QUI, 2, ONE, TR, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, MONE, M2R, 2, QUI, 2, ZERO, TI, 2 ) + CALL DGEMM( 'N', 'T', 2, 2, 2, ONE, M2I, 2, QUR, 2, ONE, TI, 2 ) + CALL DGEMM( 'T', 'N', 2, 2, 2, ONE, QBR, 2, TR, 2, ZERO, M2, + $ LDM2 ) + CALL DGEMM( 'T', 'N', 2, 2, 2, ONE, QBI, 2, TI, 2, ONE, M2, + $ LDM2 ) +C +C If the transposed equation (op(K)=K**T, K=A,B,E,U) is to be +C solved, transpose the matrix U with respect to the +C anti-diagonal and the matrices M1, M2 with respect to the diagonal +C and the anti-diagonal. +C + IF ( ISTRNS ) THEN + V = U(1,1) + U(1,1) = U(2,2) + U(2,2) = V + V = M1(1,1) + M1(1,1) = M1(2,2) + M1(2,2) = V + V = M2(1,1) + M2(1,1) = M2(2,2) + M2(2,2) = V + END IF +C + RETURN +C *** Last line of SG03BX *** + END diff --git a/mex/sources/libslicot/SG03BY.f b/mex/sources/libslicot/SG03BY.f new file mode 100644 index 000000000..356fe0423 --- /dev/null +++ b/mex/sources/libslicot/SG03BY.f @@ -0,0 +1,93 @@ + SUBROUTINE SG03BY( XR, XI, YR, YI, CR, CI, SR, SI, Z ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the parameters for the complex Givens rotation +C +C ( CR-CI*I SR-SI*I ) ( XR+XI*I ) ( Z ) +C ( ) * ( ) = ( ), +C ( -SR-SI*I CR+CI*I ) ( YR+YI*I ) ( 0 ) +C +C where CR, CI, SR, SI, XR, XI, YR, YI are real numbers and I is the +C imaginary unit, I = SQRT(-1). Z is a non-negative real number. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C XR, XI, (input) DOUBLE PRECISION +C YR, YI (input) DOUBLE PRECISION +C The given real scalars XR, XI, YR, YI. +C +C CR, CI, (output) DOUBLE PRECISION +C SR, SI, (output) DOUBLE PRECISION +C Z (output) DOUBLE PRECISION +C The computed real scalars CR, CI, SR, SI, Z, defining the +C complex Givens rotation and Z. +C +C NUMERICAL ASPECTS +C +C The subroutine avoids unnecessary overflow. +C +C FURTHER COMMENTS +C +C In the interest of speed, this routine does not check the input +C for errors. +C +C CONTRIBUTOR +C +C T. Penzl, Technical University Chemnitz, Germany, Aug. 1998. +C +C REVISIONS +C +C Sep. 1998 (V. Sima). +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION CI, CR, SI, SR, XI, XR, YI, YR, Z +C .. Intrinsic Functions .. + DOUBLE PRECISION ABS, MAX, SQRT +C .. Executable Statements .. +C + Z = MAX( ABS( XR ), ABS( XI ), ABS( YR ), ABS( YI ) ) +C + IF ( Z .EQ. ZERO ) THEN + CR = ONE + CI = ZERO + SR = ZERO + SI = ZERO + ELSE + Z = Z*SQRT( ( XR/Z )**2 + ( XI/Z )**2 + + $ ( YR/Z )**2 + ( YI/Z )**2 ) + CR = XR/Z + CI = XI/Z + SR = YR/Z + SI = YI/Z + END IF +C + RETURN +C +C *** Last line of SG03BY *** + END diff --git a/mex/sources/libslicot/TB01ID.f b/mex/sources/libslicot/TB01ID.f new file mode 100644 index 000000000..9dbedb634 --- /dev/null +++ b/mex/sources/libslicot/TB01ID.f @@ -0,0 +1,402 @@ + SUBROUTINE TB01ID( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the 1-norm of a system matrix +C +C S = ( A B ) +C ( C 0 ) +C +C corresponding to the triple (A,B,C), by balancing. This involves +C a diagonal similarity transformation inv(D)*A*D applied +C iteratively to A to make the rows and columns of +C -1 +C diag(D,I) * S * diag(D,I) +C +C as close in norm as possible. +C +C The balancing can be performed optionally on the following +C particular system matrices +C +C S = A, S = ( A B ) or S = ( A ) +C ( C ) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates which matrices are involved in balancing, as +C follows: +C = 'A': All matrices are involved in balancing; +C = 'B': B and A matrices are involved in balancing; +C = 'C': C and A matrices are involved in balancing; +C = 'N': B and C matrices are not involved in balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C MAXRED (input/output) DOUBLE PRECISION +C On entry, the maximum allowed reduction in the 1-norm of +C S (in an iteration) if zero rows or columns are +C encountered. +C If MAXRED > 0.0, MAXRED must be larger than one (to enable +C the norm reduction). +C If MAXRED <= 0.0, then the value 10.0 for MAXRED is +C used. +C On exit, if the 1-norm of the given matrix S is non-zero, +C the ratio between the 1-norm of the given matrix and the +C 1-norm of the balanced matrix. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the balanced matrix inv(D)*A*D. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, if M > 0, the leading N-by-M part of this array +C must contain the system input matrix B. +C On exit, if M > 0, the leading N-by-M part of this array +C contains the balanced matrix inv(D)*B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0. +C LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, if P > 0, the leading P-by-N part of this array +C must contain the system output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the balanced matrix C*D. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C SCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to S. If D(j) is the scaling +C factor applied to row and column j, then SCALE(j) = D(j), +C for j = 1,...,N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation +C -1 +C diag(D,I) * S * diag(D,I) +C +C to make the 1-norms of each row of the first N rows of S and its +C corresponding column nearly equal. +C +C Information about the diagonal matrix D is returned in the vector +C SCALE. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C This subroutine is based on LAPACK routine DGEBAL, and routine +C BALABC (A. Varga, German Aerospace Research Establishment, DLR). +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 1.0D+1 ) + DOUBLE PRECISION FACTOR, MAXR + PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, LDA, LDB, LDC, M, N, P + DOUBLE PRECISION MAXRED +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ SCALE( * ) +C .. +C .. Local Scalars .. + LOGICAL NOCONV, WITHB, WITHC + INTEGER I, ICA, IRA, J + DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, + $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH, IDAMAX, LSAME +C .. +C .. External Subroutines .. + EXTERNAL DSCAL, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 + WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) + WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) +C + IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. + $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TB01ID', -INFO ) + RETURN + END IF +C + IF( N.EQ.0 ) + $ RETURN +C +C Compute the 1-norm of the required part of matrix S and exit if +C it is zero. +C + SNORM = ZERO +C + DO 10 J = 1, N + SCALE( J ) = ONE + CO = DASUM( N, A( 1, J ), 1 ) + IF( WITHC .AND. P.GT.0 ) + $ CO = CO + DASUM( P, C( 1, J ), 1 ) + SNORM = MAX( SNORM, CO ) + 10 CONTINUE +C + IF( WITHB ) THEN +C + DO 20 J = 1, M + SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) + 20 CONTINUE +C + END IF +C + IF( SNORM.EQ.ZERO ) + $ RETURN +C +C Set some machine parameters and the maximum reduction in the +C 1-norm of S if zero rows or columns are encountered. +C + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C + SRED = MAXRED + IF( SRED.LE.ZERO ) SRED = MAXR +C + MAXNRM = MAX( SNORM/SRED, SFMIN1 ) +C +C Balance the matrix. +C +C Iterative loop for norm reduction. +C + 30 CONTINUE + NOCONV = .FALSE. +C + DO 90 I = 1, N + CO = ZERO + RO = ZERO +C + DO 40 J = 1, N + IF( J.EQ.I ) + $ GO TO 40 + CO = CO + ABS( A( J, I ) ) + RO = RO + ABS( A( I, J ) ) + 40 CONTINUE +C + ICA = IDAMAX( N, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IDAMAX( N, A( I, 1 ), LDA ) + RA = ABS( A( I, IRA ) ) +C + IF( WITHC .AND. P.GT.0 ) THEN + CO = CO + DASUM( P, C( 1, I ), 1 ) + ICA = IDAMAX( P, C( 1, I ), 1 ) + CA = MAX( CA, ABS( C( ICA, I ) ) ) + END IF +C + IF( WITHB .AND. M.GT.0 ) THEN + RO = RO + DASUM( M, B( I, 1 ), LDB ) + IRA = IDAMAX( M, B( I, 1 ), LDB ) + RA = MAX( RA, ABS( B( I, IRA ) ) ) + END IF +C +C Special case of zero CO and/or RO. +C + IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) + $ GO TO 90 + IF( CO.EQ.ZERO ) THEN + IF( RO.LE.MAXNRM ) + $ GO TO 90 + CO = MAXNRM + END IF + IF( RO.EQ.ZERO ) THEN + IF( CO.LE.MAXNRM ) + $ GO TO 90 + RO = MAXNRM + END IF +C +C Guard against zero CO or RO due to underflow. +C + G = RO / SCLFAC + F = ONE + S = CO + RO + 50 CONTINUE + IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. + $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 + F = F*SCLFAC + CO = CO*SCLFAC + CA = CA*SCLFAC + G = G / SCLFAC + RO = RO / SCLFAC + RA = RA / SCLFAC + GO TO 50 +C + 60 CONTINUE + G = CO / SCLFAC + 70 CONTINUE + IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. + $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 + F = F / SCLFAC + CO = CO / SCLFAC + CA = CA / SCLFAC + G = G / SCLFAC + RO = RO*SCLFAC + RA = RA*SCLFAC + GO TO 70 +C +C Now balance. +C + 80 CONTINUE + IF( ( CO+RO ).GE.FACTOR*S ) + $ GO TO 90 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 90 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 90 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +C + CALL DSCAL( N, G, A( I, 1 ), LDA ) + CALL DSCAL( N, F, A( 1, I ), 1 ) + IF( M.GT.0 ) CALL DSCAL( M, G, B( I, 1 ), LDB ) + IF( P.GT.0 ) CALL DSCAL( P, F, C( 1, I ), 1 ) +C + 90 CONTINUE +C + IF( NOCONV ) + $ GO TO 30 +C +C Set the norm reduction parameter. +C + MAXRED = SNORM + SNORM = ZERO +C + DO 100 J = 1, N + CO = DASUM( N, A( 1, J ), 1 ) + IF( WITHC .AND. P.GT.0 ) + $ CO = CO + DASUM( P, C( 1, J ), 1 ) + SNORM = MAX( SNORM, CO ) + 100 CONTINUE +C + IF( WITHB ) THEN +C + DO 110 J = 1, M + SNORM = MAX( SNORM, DASUM( N, B( 1, J ), 1 ) ) + 110 CONTINUE +C + END IF + MAXRED = MAXRED/SNORM + RETURN +C *** Last line of TB01ID *** + END diff --git a/mex/sources/libslicot/TB01IZ.f b/mex/sources/libslicot/TB01IZ.f new file mode 100644 index 000000000..e719aa390 --- /dev/null +++ b/mex/sources/libslicot/TB01IZ.f @@ -0,0 +1,409 @@ + SUBROUTINE TB01IZ( JOB, N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ SCALE, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the 1-norm of a system matrix +C +C S = ( A B ) +C ( C 0 ) +C +C corresponding to the triple (A,B,C), by balancing. This involves +C a diagonal similarity transformation inv(D)*A*D applied +C iteratively to A to make the rows and columns of +C -1 +C diag(D,I) * S * diag(D,I) +C +C as close in norm as possible. +C +C The balancing can be performed optionally on the following +C particular system matrices +C +C S = A, S = ( A B ) or S = ( A ) +C ( C ) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates which matrices are involved in balancing, as +C follows: +C = 'A': All matrices are involved in balancing; +C = 'B': B and A matrices are involved in balancing; +C = 'C': C and A matrices are involved in balancing; +C = 'N': B and C matrices are not involved in balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C MAXRED (input/output) DOUBLE PRECISION +C On entry, the maximum allowed reduction in the 1-norm of +C S (in an iteration) if zero rows or columns are +C encountered. +C If MAXRED > 0.0, MAXRED must be larger than one (to enable +C the norm reduction). +C If MAXRED <= 0.0, then the value 10.0 for MAXRED is +C used. +C On exit, if the 1-norm of the given matrix S is non-zero, +C the ratio between the 1-norm of the given matrix and the +C 1-norm of the balanced matrix. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the balanced matrix inv(D)*A*D. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= max(1,N). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,M) +C On entry, if M > 0, the leading N-by-M part of this array +C must contain the system input matrix B. +C On exit, if M > 0, the leading N-by-M part of this array +C contains the balanced matrix inv(D)*B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0. +C LDB >= 1 if M = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, if P > 0, the leading P-by-N part of this array +C must contain the system output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the balanced matrix C*D. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C SCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to S. If D(j) is the scaling +C factor applied to row and column j, then SCALE(j) = D(j), +C for j = 1,...,N. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation +C -1 +C diag(D,I) * S * diag(D,I) +C +C to make the 1-norms of each row of the first N rows of S and its +C corresponding column nearly equal. +C +C Information about the diagonal matrix D is returned in the vector +C SCALE. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION SCLFAC + PARAMETER ( SCLFAC = 1.0D+1 ) + DOUBLE PRECISION FACTOR, MAXR + PARAMETER ( FACTOR = 0.95D+0, MAXR = 10.0D+0 ) +C .. +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, LDA, LDB, LDC, M, N, P + DOUBLE PRECISION MAXRED +C .. +C .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) + DOUBLE PRECISION SCALE( * ) +C .. +C .. Local Scalars .. + LOGICAL NOCONV, WITHB, WITHC + INTEGER I, ICA, IRA, J + DOUBLE PRECISION CA, CO, F, G, MAXNRM, RA, RO, S, SFMAX1, + $ SFMAX2, SFMIN1, SFMIN2, SNORM, SRED + COMPLEX*16 CDUM +C .. +C .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, DZASUM + EXTERNAL DLAMCH, DZASUM, IZAMAX, LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, ZDSCAL +C .. +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX, MIN +C .. +C .. Statement Functions .. + DOUBLE PRECISION CABS1 +C .. +C .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 + WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) + WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) +C + IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( ( M.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. + $ ( M.EQ.0 .AND. LDB.LT.1 ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TB01IZ', -INFO ) + RETURN + END IF +C + IF( N.EQ.0 ) + $ RETURN +C +C Compute the 1-norm of the required part of matrix S and exit if +C it is zero. +C + SNORM = ZERO +C + DO 10 J = 1, N + SCALE( J ) = ONE + CO = DZASUM( N, A( 1, J ), 1 ) + IF( WITHC .AND. P.GT.0 ) + $ CO = CO + DZASUM( P, C( 1, J ), 1 ) + SNORM = MAX( SNORM, CO ) + 10 CONTINUE +C + IF( WITHB ) THEN +C + DO 20 J = 1, M + SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) + 20 CONTINUE +C + END IF +C + IF( SNORM.EQ.ZERO ) + $ RETURN +C +C Set some machine parameters and the maximum reduction in the +C 1-norm of S if zero rows or columns are encountered. +C + SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' ) + SFMAX1 = ONE / SFMIN1 + SFMIN2 = SFMIN1*SCLFAC + SFMAX2 = ONE / SFMIN2 +C + SRED = MAXRED + IF( SRED.LE.ZERO ) SRED = MAXR +C + MAXNRM = MAX( SNORM/SRED, SFMIN1 ) +C +C Balance the matrix. +C +C Iterative loop for norm reduction. +C + 30 CONTINUE + NOCONV = .FALSE. +C + DO 90 I = 1, N + CO = ZERO + RO = ZERO +C + DO 40 J = 1, N + IF( J.EQ.I ) + $ GO TO 40 + CO = CO + CABS1( A( J, I ) ) + RO = RO + CABS1( A( I, J ) ) + 40 CONTINUE +C + ICA = IZAMAX( N, A( 1, I ), 1 ) + CA = ABS( A( ICA, I ) ) + IRA = IZAMAX( N, A( I, 1 ), LDA ) + RA = ABS( A( I, IRA ) ) +C + IF( WITHC .AND. P.GT.0 ) THEN + CO = CO + DZASUM( P, C( 1, I ), 1 ) + ICA = IZAMAX( P, C( 1, I ), 1 ) + CA = MAX( CA, ABS( C( ICA, I ) ) ) + END IF +C + IF( WITHB .AND. M.GT.0 ) THEN + RO = RO + DZASUM( M, B( I, 1 ), LDB ) + IRA = IZAMAX( M, B( I, 1 ), LDB ) + RA = MAX( RA, ABS( B( I, IRA ) ) ) + END IF +C +C Special case of zero CO and/or RO. +C + IF( CO.EQ.ZERO .AND. RO.EQ.ZERO ) + $ GO TO 90 + IF( CO.EQ.ZERO ) THEN + IF( RO.LE.MAXNRM ) + $ GO TO 90 + CO = MAXNRM + END IF + IF( RO.EQ.ZERO ) THEN + IF( CO.LE.MAXNRM ) + $ GO TO 90 + RO = MAXNRM + END IF +C +C Guard against zero CO or RO due to underflow. +C + G = RO / SCLFAC + F = ONE + S = CO + RO + 50 CONTINUE + IF( CO.GE.G .OR. MAX( F, CO, CA ).GE.SFMAX2 .OR. + $ MIN( RO, G, RA ).LE.SFMIN2 )GO TO 60 + F = F*SCLFAC + CO = CO*SCLFAC + CA = CA*SCLFAC + G = G / SCLFAC + RO = RO / SCLFAC + RA = RA / SCLFAC + GO TO 50 +C + 60 CONTINUE + G = CO / SCLFAC + 70 CONTINUE + IF( G.LT.RO .OR. MAX( RO, RA ).GE.SFMAX2 .OR. + $ MIN( F, CO, G, CA ).LE.SFMIN2 )GO TO 80 + F = F / SCLFAC + CO = CO / SCLFAC + CA = CA / SCLFAC + G = G / SCLFAC + RO = RO*SCLFAC + RA = RA*SCLFAC + GO TO 70 +C +C Now balance. +C + 80 CONTINUE + IF( ( CO+RO ).GE.FACTOR*S ) + $ GO TO 90 + IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN + IF( F*SCALE( I ).LE.SFMIN1 ) + $ GO TO 90 + END IF + IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN + IF( SCALE( I ).GE.SFMAX1 / F ) + $ GO TO 90 + END IF + G = ONE / F + SCALE( I ) = SCALE( I )*F + NOCONV = .TRUE. +C + CALL ZDSCAL( N, G, A( I, 1 ), LDA ) + CALL ZDSCAL( N, F, A( 1, I ), 1 ) + IF( M.GT.0 ) CALL ZDSCAL( M, G, B( I, 1 ), LDB ) + IF( P.GT.0 ) CALL ZDSCAL( P, F, C( 1, I ), 1 ) +C + 90 CONTINUE +C + IF( NOCONV ) + $ GO TO 30 +C +C Set the norm reduction parameter. +C + MAXRED = SNORM + SNORM = ZERO +C + DO 100 J = 1, N + CO = DZASUM( N, A( 1, J ), 1 ) + IF( WITHC .AND. P.GT.0 ) + $ CO = CO + DZASUM( P, C( 1, J ), 1 ) + SNORM = MAX( SNORM, CO ) + 100 CONTINUE +C + IF( WITHB ) THEN +C + DO 110 J = 1, M + SNORM = MAX( SNORM, DZASUM( N, B( 1, J ), 1 ) ) + 110 CONTINUE +C + END IF + MAXRED = MAXRED/SNORM + RETURN +C *** Last line of TB01IZ *** + END diff --git a/mex/sources/libslicot/TB01KD.f b/mex/sources/libslicot/TB01KD.f new file mode 100644 index 000000000..a3d0a85d2 --- /dev/null +++ b/mex/sources/libslicot/TB01KD.f @@ -0,0 +1,334 @@ + SUBROUTINE TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, + $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute an additive spectral decomposition of the transfer- +C function matrix of the system (A,B,C) by reducing the system +C state-matrix A to a block-diagonal form. +C The system matrices are transformed as +C A <-- inv(U)*A*U, B <--inv(U)*B and C <-- C*U. +C The leading diagonal block of the resulting A has eigenvalues +C in a suitably defined domain of interest. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C JOBA CHARACTER*1 +C Specifies the shape of the state dynamics matrix on entry +C as follows: +C = 'S': A is in an upper real Schur form; +C = 'G': A is a general square dense matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION. +C Specifies the boundary of the domain of interest for the +C eigenvalues of A. For a continuous-time system +C (DICO = 'C'), ALPHA is the boundary value for the real +C parts of eigenvalues, while for a discrete-time system +C (DICO = 'D'), ALPHA >= 0 represents the boundary value for +C the moduli of eigenvalues. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the unreduced state dynamics matrix A. +C If JOBA = 'S' then A must be a matrix in real Schur form. +C On exit, the leading N-by-N part of this array contains a +C block diagonal matrix inv(U) * A * U with two diagonal +C blocks in real Schur form with the elements below the +C first subdiagonal set to zero. +C The leading NDIM-by-NDIM block of A has eigenvalues in the +C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) +C block has eigenvalues outside the domain of interest. +C The domain of interest for lambda(A), the eigenvalues +C of A, is defined by the parameters ALPHA, DICO and STDOM +C as follows: +C For a continuous-time system (DICO = 'C'): +C Real(lambda(A)) < ALPHA if STDOM = 'S'; +C Real(lambda(A)) > ALPHA if STDOM = 'U'; +C For a discrete-time system (DICO = 'D'): +C Abs(lambda(A)) < ALPHA if STDOM = 'S'; +C Abs(lambda(A)) > ALPHA if STDOM = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix inv(U) * B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * U. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NDIM (output) INTEGER +C The number of eigenvalues of A lying inside the domain of +C interest for eigenvalues. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C transformation matrix used to reduce A to the block- +C diagonal form. The first NDIM columns of U span the +C invariant subspace of A corresponding to the eigenvalues +C of its leading diagonal block. The last N-NDIM columns +C of U span the reducing subspace of A corresponding to +C the eigenvalues of the trailing diagonal block of A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C WR and WI contain the real and imaginary parts, +C respectively, of the computed eigenvalues of A. The +C eigenvalues will be in the same order that they appear on +C the diagonal of the output real Schur form of A. Complex +C conjugate pairs of eigenvalues will appear consecutively +C with the eigenvalue having the positive imaginary part +C first. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX(1,N) if JOBA = 'S'; +C LDWORK >= MAX(1,3*N) if JOBA = 'G'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm failed to compute all the +C eigenvalues of A; +C = 2: a failure occured during the ordering of the real +C Schur form of A; +C = 3: the separation of the two diagonal blocks failed +C because of very close eigenvalues. +C +C METHOD +C +C A similarity transformation U is determined that reduces the +C system state-matrix A to a block-diagonal form (with two diagonal +C blocks), so that the leading diagonal block of the resulting A has +C eigenvalues in a specified domain of the complex plane. The +C determined transformation is applied to the system (A,B,C) as +C A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U. +C +C REFERENCES +C +C [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N. +C Synthesis of positive real multivariable feedback systems. +C Int. J. Control, pp. 817-842, 1987. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires about 14N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SADSDC. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Invariant subspace, real Schur form, similarity transformation, +C spectral factorization. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBA, STDOM + INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), + $ WI(*), WR(*) +C .. Local Scalars .. + LOGICAL DISCR, LJOBG + INTEGER NDIM1, NR + DOUBLE PRECISION SCALE +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEMM, DLASET, DTRSYL, TB01LD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LJOBG = LSAME( JOBA, 'G' ) +C +C Check input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. + $ LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. + $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01KD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NDIM = 0 + IF( N.EQ.0 ) + $ RETURN +C +C Reduce A to an ordered real Schur form using an orthogonal +C similarity transformation A <- U'*A*U and accumulate the +C transformations in U. The reordering of the real Schur form of A +C is performed in accordance with the values of the parameters DICO, +C STDOM and ALPHA. Apply the transformation to B and C: B <- U'*B +C and C <- C*U. The eigenvalues of A are computed in (WR,WI). +C +C Workspace: need 3*N (if JOBA = 'G'), or N (if JOBA = 'S'); +C prefer larger. +C + CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, LDB, C, + $ LDC, NDIM, U, LDU, WR, WI, DWORK, LDWORK, INFO ) +C + IF ( INFO.NE.0 ) + $ RETURN +C + IF ( NDIM.GT.0 .AND. NDIM.LT.N ) THEN +C +C Reduce A to a block-diagonal form by a similarity +C transformation of the form +C -1 ( I -X ) +C A <- T AT, where T = ( ) and X satisfies the +C ( 0 I ) +C Sylvester equation +C +C A11*X - X*A22 = A12. +C + NR = N - NDIM + NDIM1 = NDIM + 1 + CALL DTRSYL( 'N', 'N', -1, NDIM, NR, A, LDA, A(NDIM1,NDIM1), + $ LDA, A(1,NDIM1), LDA, SCALE, INFO ) + IF ( INFO.NE.0 ) THEN + INFO = 3 + RETURN + END IF +C -1 +C Compute B <- T B, C <- CT, U <- UT. +C + SCALE = ONE/SCALE + CALL DGEMM( 'N', 'N', NDIM, M, NR, SCALE, A(1,NDIM1), LDA, + $ B(NDIM1,1), LDB, ONE, B, LDB ) + CALL DGEMM( 'N', 'N', P, NR, NDIM, -SCALE, C, LDC, A(1,NDIM1), + $ LDA, ONE, C(1,NDIM1), LDC ) + CALL DGEMM( 'N', 'N', N, NR, NDIM, -SCALE, U, LDU, A(1,NDIM1), + $ LDA, ONE, U(1,NDIM1), LDU ) +C +C Set A12 to zero. +C + CALL DLASET( 'Full', NDIM, NR, ZERO, ZERO, A(1,NDIM1), LDA ) + END IF +C +C Set to zero the lower triangular part under the first subdiagonal +C of A. +C + IF ( N.GT.2 ) + $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA ) + RETURN +C *** Last line of TB01KD *** + END diff --git a/mex/sources/libslicot/TB01LD.f b/mex/sources/libslicot/TB01LD.f new file mode 100644 index 000000000..50f64c914 --- /dev/null +++ b/mex/sources/libslicot/TB01LD.f @@ -0,0 +1,348 @@ + SUBROUTINE TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, + $ LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the system state matrix A to an ordered upper real +C Schur form by using an orthogonal similarity transformation +C A <-- U'*A*U and to apply the transformation to the matrices +C B and C: B <-- U'*B and C <-- C*U. +C The leading block of the resulting A has eigenvalues in a +C suitably defined domain of interest. +C +C ARGUMENTS +C +C Mode Parameters +C +C DICO CHARACTER*1 +C Specifies the type of the system as follows: +C = 'C': continuous-time system; +C = 'D': discrete-time system. +C +C STDOM CHARACTER*1 +C Specifies whether the domain of interest is of stability +C type (left part of complex plane or inside of a circle) +C or of instability type (right part of complex plane or +C outside of a circle) as follows: +C = 'S': stability type domain; +C = 'U': instability type domain. +C +C JOBA CHARACTER*1 +C Specifies the shape of the state dynamics matrix on entry +C as follows: +C = 'S': A is in an upper real Schur form; +C = 'G': A is a general square dense matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C ALPHA (input) DOUBLE PRECISION. +C Specifies the boundary of the domain of interest for the +C eigenvalues of A. For a continuous-time system +C (DICO = 'C'), ALPHA is the boundary value for the real +C parts of eigenvalues, while for a discrete-time system +C (DICO = 'D'), ALPHA >= 0 represents the boundary value +C for the moduli of eigenvalues. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the unreduced state dynamics matrix A. +C If JOBA = 'S' then A must be a matrix in real Schur form. +C On exit, the leading N-by-N part of this array contains +C the ordered real Schur matrix U' * A * U with the elements +C below the first subdiagonal set to zero. +C The leading NDIM-by-NDIM part of A has eigenvalues in the +C domain of interest and the trailing (N-NDIM)-by-(N-NDIM) +C part has eigenvalues outside the domain of interest. +C The domain of interest for lambda(A), the eigenvalues +C of A, is defined by the parameters ALPHA, DICO and STDOM +C as follows: +C For a continuous-time system (DICO = 'C'): +C Real(lambda(A)) < ALPHA if STDOM = 'S'; +C Real(lambda(A)) > ALPHA if STDOM = 'U'; +C For a discrete-time system (DICO = 'D'): +C Abs(lambda(A)) < ALPHA if STDOM = 'S'; +C Abs(lambda(A)) > ALPHA if STDOM = 'U'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix U' * B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * U. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NDIM (output) INTEGER +C The number of eigenvalues of A lying inside the domain of +C interest for eigenvalues. +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C orthogonal transformation matrix used to reduce A to the +C real Schur form and/or to reorder the diagonal blocks of +C real Schur form of A. The first NDIM columns of U form +C an orthogonal basis for the invariant subspace of A +C corresponding to the first NDIM eigenvalues. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C WR and WI contain the real and imaginary parts, +C respectively, of the computed eigenvalues of A. The +C eigenvalues will be in the same order that they appear on +C the diagonal of the output real Schur form of A. Complex +C conjugate pairs of eigenvalues will appear consecutively +C with the eigenvalue having the positive imaginary part +C first. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. +C LDWORK >= MAX(1,N) if JOBA = 'S'; +C LDWORK >= MAX(1,3*N) if JOBA = 'G'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm failed to compute all the +C eigenvalues of A; +C = 2: a failure occured during the ordering of the real +C Schur form of A. +C +C METHOD +C +C Matrix A is reduced to an ordered upper real Schur form using an +C orthogonal similarity transformation A <-- U'*A*U. This +C transformation is determined so that the leading block of the +C resulting A has eigenvalues in a suitably defined domain of +C interest. Then, the transformation is applied to the matrices B +C and C: B <-- U'*B and C <-- C*U. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires about 14N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRSFOD. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001. +C +C KEYWORDS +C +C Invariant subspace, orthogonal transformation, real Schur form, +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER DICO, JOBA, STDOM + INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P + DOUBLE PRECISION ALPHA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), + $ WI(*), WR(*) +C .. Local Scalars .. + LOGICAL DISCR, LJOBG + INTEGER I, IERR, LDWP, SDIM + DOUBLE PRECISION WRKOPT +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, DLASET, + $ MB03QD, MB03QX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C + INFO = 0 + DISCR = LSAME( DICO, 'D' ) + LJOBG = LSAME( JOBA, 'G' ) +C +C Check input scalar arguments. +C + IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR. + $ LSAME( STDOM, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDWORK.LT.MAX( 1, N ) .OR. + $ LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01LD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NDIM = 0 + IF( N.EQ.0 ) + $ RETURN +C + IF( LSAME( JOBA, 'G' ) ) THEN +C +C Reduce A to real Schur form using an orthogonal similarity +C transformation A <- U'*A*U, accumulate the transformation in U +C and compute the eigenvalues of A in (WR,WI). +C +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + WRKOPT = DWORK( 1 ) + IF( INFO.NE.0 ) THEN + INFO = 1 + RETURN + END IF + ELSE +C +C Initialize U with an identity matrix. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) + WRKOPT = 0 + END IF +C +C Separate the spectrum of A. The leading NDIM-by-NDIM submatrix of +C A corresponds to the eigenvalues of interest. +C Workspace: need N. +C + CALL MB03QD( DICO, STDOM, 'Update', N, 1, N, ALPHA, A, LDA, + $ U, LDU, NDIM, DWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN +C +C Compute the eigenvalues. +C + CALL MB03QX( N, A, LDA, WR, WI, IERR ) +C +C Apply the transformation: B <-- U'*B. +C + IF( LDWORK.LT.N*M ) THEN +C +C Not enough working space for using DGEMM. +C + DO 10 I = 1, M + CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ B(1,I), 1 ) + 10 CONTINUE +C + ELSE + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, + $ DWORK, N, ZERO, B, LDB ) + WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) + END IF +C +C Apply the transformation: C <-- C*U. +C + IF( LDWORK.LT.N*P ) THEN +C +C Not enough working space for using DGEMM. +C + DO 20 I = 1, P + CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ C(I,1), LDC ) + 20 CONTINUE +C + ELSE + LDWP = MAX( 1, P ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) + CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, + $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) + WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) + END IF +C + DWORK( 1 ) = WRKOPT +C + RETURN +C *** Last line of TB01LD *** + END diff --git a/mex/sources/libslicot/TB01MD.f b/mex/sources/libslicot/TB01MD.f new file mode 100644 index 000000000..b63aacee0 --- /dev/null +++ b/mex/sources/libslicot/TB01MD.f @@ -0,0 +1,338 @@ + SUBROUTINE TB01MD( JOBU, UPLO, N, M, A, LDA, B, LDB, U, LDU, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the pair (B,A) to upper or lower controller Hessenberg +C form using (and optionally accumulating) unitary state-space +C transformations. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix U the unitary state-space transformations for +C reducing the system, as follows: +C = 'N': Do not form U; +C = 'I': U is initialized to the unit matrix and the +C unitary transformation matrix U is returned; +C = 'U': The given matrix U is updated by the unitary +C transformations used in the reduction. +C +C UPLO CHARACTER*1 +C Indicates whether the user wishes the pair (B,A) to be +C reduced to upper or lower controller Hessenberg form as +C follows: +C = 'U': Upper controller Hessenberg form; +C = 'L': Lower controller Hessenberg form. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the +C matrix A. N >= 0. +C +C M (input) INTEGER +C The actual input dimension, i.e. the number of columns of +C the matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state transition matrix A to be transformed. +C On exit, the leading N-by-N part of this array contains +C the transformed state transition matrix U' * A * U. +C The annihilated elements are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B to be transformed. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix U' * B. +C The annihilated elements are set to zero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) +C On entry, if JOBU = 'U', then the leading N-by-N part of +C this array must contain a given matrix U (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading N-by-N part of this array contains the product of +C the input matrix U and the state-space transformation +C matrix which reduces the given pair to controller +C Hessenberg form. +C On exit, if JOBU = 'I', then the leading N-by-N part of +C this array contains the matrix of accumulated unitary +C similarity transformations which reduces the given pair +C to controller Hessenberg form. +C If JOBU = 'N', the array U is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDU = 1 and +C declare this array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. If JOBU = 'U' or +C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N,M-1)) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a unitary state-space transformation U, which +C reduces the pair (B,A) to one of the following controller +C Hessenberg forms: +C +C |* . . . *|* . . . . . . *| +C | . .|. .| +C | . .|. .| +C | . .|. .| +C [U'B|U'AU] = | *|. .| N +C | |* .| +C | | . .| +C | | . .| +C | | . .| +C | | * . . *| +C M N +C +C if UPLO = 'U', or +C +C |* . . * | | +C |. . | | +C |. . | | +C |. . | | +C [U'AU|U'B] = |. *| | N +C |. .|* | +C |. .|. . | +C |. .|. . | +C |. .|. . | +C |* . . . . . . *|* . . . *| +C N M +C if UPLO = 'L'. +C +C IF M >= N, then the matrix U'B is trapezoidal and U'AU is full. +C +C REFERENCES +C +C [1] Van Dooren, P. and Verhaegen, M.H.G. +C On the use of unitary state-space transformations. +C In : Contemporary Mathematics on Linear Algebra and its Role +C in Systems Theory, 47, AMS, Providence, 1985. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O((N + M) x N**2) operations and is +C backward stable (see [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01AD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C February 1997. +C +C KEYWORDS +C +C Controllability, controller Hessenberg form, orthogonal +C transformation, unitary transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBU, UPLO + INTEGER INFO, LDA, LDB, LDU, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), U(LDU,*) +C .. Local Scalars .. + LOGICAL LJOBA, LJOBI, LUPLO + INTEGER II, J, M1, N1, NJ, PAR1, PAR2, PAR3, PAR4, PAR5, + $ PAR6 + DOUBLE PRECISION DZ +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, DLASET, DLATZM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LJOBI = LSAME( JOBU, 'I' ) + LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. + $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'TB01MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +C + M1 = M + 1 + N1 = N - 1 +C + IF ( LJOBI ) THEN +C +C Initialize U to the identity matrix. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) + END IF +C +C Perform transformations involving both B and A. +C + DO 20 J = 1, MIN( M, N1 ) + NJ = N - J + IF ( LUPLO ) THEN + PAR1 = J + PAR2 = J + PAR3 = J + 1 + PAR4 = M + PAR5 = N + ELSE + PAR1 = M - J + 1 + PAR2 = NJ + 1 + PAR3 = 1 + PAR4 = M - J + PAR5 = NJ + END IF +C + CALL DLARFG( NJ+1, B(PAR2,PAR1), B(PAR3,PAR1), 1, DZ ) +C +C Update A. +C + CALL DLATZM( 'Left', NJ+1, N, B(PAR3,PAR1), 1, DZ, A(PAR2,1), + $ A(PAR3,1), LDA, DWORK ) + CALL DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, A(1,PAR2), + $ A(1,PAR3), LDA, DWORK ) +C + IF ( LJOBA ) THEN +C +C Update U. +C + CALL DLATZM( 'Right', N, NJ+1, B(PAR3,PAR1), 1, DZ, + $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) + END IF +C + IF ( J.NE.M ) THEN +C +C Update B +C + CALL DLATZM( 'Left', NJ+1, PAR4-PAR3+1, B(PAR3,PAR1), 1, DZ, + $ B(PAR2,PAR3), B(PAR3,PAR3), LDB, DWORK ) + END IF +C + DO 10 II = PAR3, PAR5 + B(II,PAR1) = ZERO + 10 CONTINUE +C + 20 CONTINUE +C + DO 40 J = M1, N1 +C +C Perform next transformations only involving A. +C + NJ = N - J + IF ( LUPLO ) THEN + PAR1 = J - M + PAR2 = J + PAR3 = J + 1 + PAR4 = N + PAR5 = J - M + 1 + PAR6 = N + ELSE + PAR1 = N + M1 - J + PAR2 = NJ + 1 + PAR3 = 1 + PAR4 = NJ + PAR5 = 1 + PAR6 = N + M - J + END IF +C + CALL DLARFG( NJ+1, A(PAR2,PAR1), A(PAR3,PAR1), 1, DZ ) +C +C Update A. +C + CALL DLATZM( 'Left', NJ+1, PAR6-PAR5+1, A(PAR3,PAR1), 1, DZ, + $ A(PAR2,PAR5), A(PAR3,PAR5), LDA, DWORK ) + CALL DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, + $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) +C + IF ( LJOBA ) THEN +C +C Update U. +C + CALL DLATZM( 'Right', N, NJ+1, A(PAR3,PAR1), 1, DZ, + $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) + END IF +C + DO 30 II = PAR3, PAR4 + A(II,PAR1) = ZERO + 30 CONTINUE +C + 40 CONTINUE +C + RETURN +C *** Last line of TB01MD *** + END diff --git a/mex/sources/libslicot/TB01ND.f b/mex/sources/libslicot/TB01ND.f new file mode 100644 index 000000000..cc93dd3ac --- /dev/null +++ b/mex/sources/libslicot/TB01ND.f @@ -0,0 +1,349 @@ + SUBROUTINE TB01ND( JOBU, UPLO, N, P, A, LDA, C, LDC, U, LDU, + $ DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the pair (A,C) to lower or upper observer Hessenberg +C form using (and optionally accumulating) unitary state-space +C transformations. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBU CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix U the unitary state-space transformations for +C reducing the system, as follows: +C = 'N': Do not form U; +C = 'I': U is initialized to the unit matrix and the +C unitary transformation matrix U is returned; +C = 'U': The given matrix U is updated by the unitary +C transformations used in the reduction. +C +C UPLO CHARACTER*1 +C Indicates whether the user wishes the pair (A,C) to be +C reduced to upper or lower observer Hessenberg form as +C follows: +C = 'U': Upper observer Hessenberg form; +C = 'L': Lower observer Hessenberg form. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The actual state dimension, i.e. the order of the +C matrix A. N >= 0. +C +C P (input) INTEGER +C The actual output dimension, i.e. the number of rows of +C the matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state transition matrix A to be transformed. +C On exit, the leading N-by-N part of this array contains +C the transformed state transition matrix U' * A * U. +C The annihilated elements are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C to be transformed. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * U. +C The annihilated elements are set to zero. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C U (input/output) DOUBLE PRECISION array, dimension (LDU,*) +C On entry, if JOBU = 'U', then the leading N-by-N part of +C this array must contain a given matrix U (e.g. from a +C previous call to another SLICOT routine), and on exit, the +C leading N-by-N part of this array contains the product of +C the input matrix U and the state-space transformation +C matrix which reduces the given pair to observer Hessenberg +C form. +C On exit, if JOBU = 'I', then the leading N-by-N part of +C this array contains the matrix of accumulated unitary +C similarity transformations which reduces the given pair +C to observer Hessenberg form. +C If JOBU = 'N', the array U is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDU = 1 and +C declare this array to be U(1,1) in the calling program). +C +C LDU INTEGER +C The leading dimension of array U. If JOBU = 'U' or +C JOBU = 'I', LDU >= MAX(1,N); if JOBU = 'N', LDU >= 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (MAX(N,P-1)) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a unitary state-space transformation U, which +C reduces the pair (A,C) to one of the following observer Hessenberg +C forms: +C +C N +C |* . . . . . . *| +C |. .| +C |. .| +C |. .| N +C |* .| +C |U'AU| | . .| +C |----| = | . .| +C |CU | | * . . . *| +C ------------------- +C | * . . *| +C | . .| P +C | . .| +C | *| +C +C if UPLO = 'U', or +C +C N +C |* | +C |. . | +C |. . | P +C |* . . * | +C |CU | ------------------- +C |----| = |* . . . * | +C |U'AU| |. . | +C |. . | +C |. *| +C |. .| N +C |. .| +C |. .| +C |* . . . . . . *| +C +C if UPLO = 'L'. +C +C If P >= N, then the matrix CU is trapezoidal and U'AU is full. +C +C REFERENCES +C +C [1] Van Dooren, P. and Verhaegen, M.H.G. +C On the use of unitary state-space transformations. +C In : Contemporary Mathematics on Linear Algebra and its Role +C in Systems Theory, 47, AMS, Providence, 1985. +C +C NUMERICAL ASPECTS +C +C The algorithm requires O((N + P) x N**2) operations and is +C backward stable (see [1]). +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01BD by M. Vanbegin, and +C P. Van Dooren, Philips Research Laboratory, Brussels, Belgium. +C +C REVISIONS +C +C February 1997. +C +C KEYWORDS +C +C Controllability, observer Hessenberg form, orthogonal +C transformation, unitary transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDC, LDU, N, P + CHARACTER JOBU, UPLO +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), C(LDC,*), DWORK(*), U(LDU,*) +C .. Local Scalars .. + LOGICAL LJOBA, LJOBI, LUPLO + INTEGER II, J, N1, NJ, P1, PAR1, PAR2, PAR3, PAR4, PAR5, + $ PAR6 + DOUBLE PRECISION DZ +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLARFG, DLASET, DLATZM, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) + LJOBI = LSAME( JOBU, 'I' ) + LJOBA = LJOBI.OR.LSAME( JOBU, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBA .AND. .NOT.LSAME( JOBU, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( .NOT.LJOBA .AND. LDU.LT.1 .OR. + $ LJOBA .AND. LDU.LT.MAX( 1, N ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'TB01ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. P.EQ.0 ) + $ RETURN +C + P1 = P + 1 + N1 = N - 1 +C + IF ( LJOBI ) THEN +C +C Initialize U to the identity matrix. +C + CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU ) + END IF +C +C Perform transformations involving both C and A. +C + DO 20 J = 1, MIN( P, N1 ) + NJ = N - J + IF ( LUPLO ) THEN + PAR1 = P - J + 1 + PAR2 = NJ + 1 + PAR3 = 1 + PAR4 = P - J + PAR5 = NJ + ELSE + PAR1 = J + PAR2 = J + PAR3 = J + 1 + PAR4 = P + PAR5 = N + END IF +C + CALL DLARFG( NJ+1, C(PAR1,PAR2), C(PAR1,PAR3), LDC, DZ ) +C +C Update A. +C + CALL DLATZM( 'Left', NJ+1, N, C(PAR1,PAR3), LDC, DZ, A(PAR2,1), + $ A(PAR3,1), LDA, DWORK ) + CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, + $ A(1,PAR2), A(1,PAR3), LDA, DWORK ) +C + IF ( LJOBA ) THEN +C +C Update U. +C + CALL DLATZM( 'Right', N, NJ+1, C(PAR1,PAR3), LDC, DZ, + $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) + END IF +C + IF ( J.NE.P ) THEN +C +C Update C. +C + CALL DLATZM( 'Right', PAR4-PAR3+1, NJ+1, C(PAR1,PAR3), LDC, + $ DZ, C(PAR3,PAR2), C(PAR3,PAR3), LDC, DWORK ) + END IF +C + DO 10 II = PAR3, PAR5 + C(PAR1,II) = ZERO + 10 CONTINUE +C + 20 CONTINUE +C + DO 40 J = P1, N1 +C +C Perform next transformations only involving A. +C + NJ = N - J + IF ( LUPLO ) THEN + PAR1 = N + P1 - J + PAR2 = NJ + 1 + PAR3 = 1 + PAR4 = NJ + PAR5 = 1 + PAR6 = N + P - J + ELSE + PAR1 = J - P + PAR2 = J + PAR3 = J + 1 + PAR4 = N + PAR5 = J - P + 1 + PAR6 = N + END IF +C + IF ( NJ.GT.0 ) THEN +C + CALL DLARFG( NJ+1, A(PAR1,PAR2), A(PAR1,PAR3), LDA, DZ ) +C +C Update A. +C + CALL DLATZM( 'Left', NJ+1, N, A(PAR1,PAR3), LDA, DZ, + $ A(PAR2,1), A(PAR3,1), LDA, DWORK ) + CALL DLATZM( 'Right', PAR6-PAR5+1, NJ+1, A(PAR1,PAR3), LDA, + $ DZ, A(PAR5,PAR2), A(PAR5,PAR3), LDA, DWORK ) +C + IF ( LJOBA ) THEN +C +C Update U. +C + CALL DLATZM( 'Right', N, NJ+1, A(PAR1,PAR3), LDA, DZ, + $ U(1,PAR2), U(1,PAR3), LDU, DWORK ) + END IF +C + DO 30 II = PAR3, PAR4 + A(PAR1,II) = ZERO + 30 CONTINUE +C + END IF +C + 40 CONTINUE +C + RETURN +C *** Last line of TB01ND *** + END diff --git a/mex/sources/libslicot/TB01PD.f b/mex/sources/libslicot/TB01PD.f new file mode 100644 index 000000000..c1c9594bd --- /dev/null +++ b/mex/sources/libslicot/TB01PD.f @@ -0,0 +1,352 @@ + SUBROUTINE TB01PD( JOB, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, + $ NR, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a reduced (controllable, observable, or minimal) state- +C space representation (Ar,Br,Cr) for any original state-space +C representation (A,B,C). The matrix Ar is in upper block +C Hessenberg form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to remove the +C uncontrollable and/or unobservable parts as follows: +C = 'M': Remove both the uncontrollable and unobservable +C parts to get a minimal state-space representation; +C = 'C': Remove the uncontrollable part only to get a +C controllable state-space representation; +C = 'O': Remove the unobservable part only to get an +C observable state-space representation. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily balance +C the triplet (A,B,C) as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, i.e. +C the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NR-by-NR part of this array contains +C the upper block Hessenberg state dynamics matrix Ar of a +C minimal, controllable, or observable realization for the +C original system, depending on the value of JOB, JOB = 'M', +C JOB = 'C', or JOB = 'O', respectively. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), +C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B; if JOB = 'M', +C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) +C part is used as internal workspace. +C On exit, the leading NR-by-M part of this array contains +C the transformed input/state matrix Br of a minimal, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'M', +C JOB = 'C', or JOB = 'O', respectively. +C If JOB = 'C', only the first IWORK(1) rows of B are +C nonzero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C; if JOB = 'M', +C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N +C part is used as internal workspace. +C On exit, the leading P-by-NR part of this array contains +C the transformed state/output matrix Cr of a minimal, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'M', +C JOB = 'C', or JOB = 'O', respectively. +C If JOB = 'M', or JOB = 'O', only the last IWORK(1) columns +C (in the first NR columns) of C are nonzero. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C NR (output) INTEGER +C The order of the reduced state-space representation +C (Ar,Br,Cr) of a minimal, controllable, or observable +C realization for the original system, depending on +C JOB = 'M', JOB = 'C', or JOB = 'O'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B, C). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance +C (determined by the SLICOT routine TB01UD) is used instead. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If JOB = 'M', the matrices A and B are operated on by orthogonal +C similarity transformations (made up of products of Householder +C transformations) so as to produce an upper block Hessenberg matrix +C A1 and a matrix B1 with all but its first rank(B) rows zero; this +C separates out the controllable part of the original system. +C Applying the same algorithm to the dual of this subsystem, +C therefore separates out the controllable and observable (i.e. +C minimal) part of the original system representation, with the +C final Ar upper block Hessenberg (after using pertransposition). +C If JOB = 'C', or JOB = 'O', only the corresponding part of the +C above procedure is applied. +C +C REFERENCES +C +C [1] Van Dooren, P. +C The Generalized Eigenstructure Problem in Linear System +C Theory. (Algorithm 1) +C IEEE Trans. Auto. Contr., AC-26, pp. 111-129, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C A. Varga, DLR Oberpfaffenhofen, July 1998. +C A. Varga, DLR Oberpfaffenhofen, April 28, 1999. +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Hessenberg form, minimal realization, multivariable system, +C orthogonal transformation, state-space model, state-space +C representation. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER LDIZ + PARAMETER ( LDIZ = 1 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, JOB + INTEGER INFO, LDA, LDB, LDC, LDWORK, M, N, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*) +C .. Local Scalars .. + LOGICAL LEQUIL, LNJOBC, LNJOBO + INTEGER I, INDCON, ITAU, IZ, JWORK, KL, MAXMP, NCONT, + $ WRKOPT + DOUBLE PRECISION MAXRED +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, TB01ID, TB01UD, TB01XD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + MAXMP = MAX( M, P ) + LNJOBC = .NOT.LSAME( JOB, 'C' ) + LNJOBO = .NOT.LSAME( JOB, 'O' ) + LEQUIL = LSAME( EQUIL, 'S' ) +C +C Test the input scalar arguments. +C + IF( LNJOBC .AND. LNJOBO .AND. .NOT.LSAME( JOB, 'M' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ) ) ) THEN + INFO = -16 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 .OR. ( LNJOBC .AND. MIN( N, P ).EQ.0 ) .OR. + $ ( LNJOBO .AND. MIN( N, M ).EQ.0 ) ) THEN + NR = 0 +C + DO 5 I = 1, N + IWORK(I) = 0 + 5 CONTINUE +C + DWORK(1) = ONE + RETURN + END IF +C +C If required, balance the triplet (A,B,C) (default MAXRED). +C Workspace: need N. +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the code, +C as well as the preferred amount for good performance.) +C + IF ( LEQUIL ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, INFO ) + WRKOPT = N + ELSE + WRKOPT = 1 + END IF +C + IZ = 1 + ITAU = 1 + JWORK = ITAU + N + IF ( LNJOBO ) THEN +C +C Separate out controllable subsystem (of order NCONT): +C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. +C +C Workspace: need N + MAX(N, 3*M, P). +C prefer larger. +C + CALL TB01UD( 'No Z', N, M, P, A, LDA, B, LDB, C, LDC, NCONT, + $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, + $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 + ELSE + NCONT = N + END IF +C + IF ( LNJOBC ) THEN +C +C Separate out the observable subsystem (of order NR): +C Form the dual of the subsystem of order NCONT (which is +C controllable, if JOB = 'M'), leaving rest as it is. +C + CALL AB07MD( 'Z', NCONT, M, P, A, LDA, B, LDB, C, LDC, DWORK, + $ 1, INFO ) +C +C And separate out the controllable part of this dual subsystem. +C +C Workspace: need NCONT + MAX(NCONT, 3*P, M). +C prefer larger. +C + CALL TB01UD( 'No Z', NCONT, P, M, A, LDA, B, LDB, C, LDC, NR, + $ INDCON, IWORK, DWORK(IZ), LDIZ, DWORK(ITAU), TOL, + $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Transpose and reorder (to get a block upper Hessenberg +C matrix A), giving, for JOB = 'M', the controllable and +C observable (i.e., minimal) part of original system. +C + IF( INDCON.GT.0 ) THEN + KL = IWORK(1) - 1 + IF ( INDCON.GE.2 ) + $ KL = KL + IWORK(2) + ELSE + KL = 0 + END IF + CALL TB01XD( 'Zero D', NR, P, M, KL, MAX( 0, NR-1 ), A, LDA, + $ B, LDB, C, LDC, DWORK, 1, INFO ) + ELSE + NR = NCONT + END IF +C +C Annihilate the trailing components of IWORK(1:N). +C + DO 10 I = INDCON + 1, N + IWORK(I) = 0 + 10 CONTINUE +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of TB01PD *** + END diff --git a/mex/sources/libslicot/TB01TD.f b/mex/sources/libslicot/TB01TD.f new file mode 100644 index 000000000..7c52957ad --- /dev/null +++ b/mex/sources/libslicot/TB01TD.f @@ -0,0 +1,308 @@ + SUBROUTINE TB01TD( N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, LOW, + $ IGH, SCSTAT, SCIN, SCOUT, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce a given state-space representation (A,B,C,D) to +C balanced form by means of state permutations and state, input and +C output scalings. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the original state dynamics matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the balanced state dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, the leading N-by-M part of this array contains +C the balanced input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the balanced state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input/output) DOUBLE PRECISION array, dimension (LDD,M) +C On entry, the leading P-by-M part of this array must +C contain the original direct transmission matrix D. +C On exit, the leading P-by-M part of this array contains +C the scaled direct transmission matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C LOW (output) INTEGER +C The index of the lower end of the balanced submatrix of A. +C +C IGH (output) INTEGER +C The index of the upper end of the balanced submatrix of A. +C +C SCSTAT (output) DOUBLE PRECISION array, dimension (N) +C This array contains the information defining the +C similarity transformations used to permute and balance +C the state dynamics matrix A, as returned from the LAPACK +C library routine DGEBAL. +C +C SCIN (output) DOUBLE PRECISION array, dimension (M) +C Contains the scalars used to scale the system inputs so +C that the columns of the final matrix B have norms roughly +C equal to the column sums of the balanced matrix A +C (see FURTHER COMMENTS). +C The j-th input of the balanced state-space representation +C is SCIN(j)*(j-th column of the permuted and balanced +C input/state matrix B). +C +C SCOUT (output) DOUBLE PRECISION array, dimension (P) +C Contains the scalars used to scale the system outputs so +C that the rows of the final matrix C have norms roughly +C equal to the row sum of the balanced matrix A. +C The i-th output of the balanced state-space representation +C is SCOUT(i)*(i-th row of the permuted and balanced +C state/ouput matrix C). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Similarity transformations are used to permute the system states +C and balance the corresponding row and column sum norms of a +C submatrix of the state dynamics matrix A. These operations are +C also applied to the input/state matrix B and the system inputs +C are then scaled (see parameter SCIN) so that the columns of the +C final matrix B have norms roughly equal to the column sum norm of +C the balanced matrix A (see FURTHER COMMENTS). +C The above operations are also applied to the matrix C, and the +C system outputs are then scaled (see parameter SCOUT) so that the +C rows of the final matrix C have norms roughly equal to the row sum +C norm of the balanced matrix A (see FURTHER COMMENTS). +C Finally, the (I,J)-th element of the direct transmission matrix D +C is scaled as +C D(I,J) = D(I,J)*(1.0/SCIN(J))*SCOUT(I), where I = 1,2,...,P +C and J = 1,2,...,M. +C +C Scaling performed to balance the row/column sum norms is by +C integer powers of the machine base so as to avoid introducing +C rounding errors. +C +C REFERENCES +C +C [1] Wilkinson, J.H. and Reinsch, C. +C Handbook for Automatic Computation, (Vol II, Linear Algebra). +C Springer-Verlag, 1971, (contribution II/11). +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C The columns (rows) of the final matrix B (matrix C) have norms +C 'roughly' equal to the column (row) sum norm of the balanced +C matrix A, i.e. +C size/BASE < abssum <= size +C where +C BASE = the base of the arithmetic used on the computer, which +C can be obtained from the LAPACK Library routine +C DLAMCH; +C +C size = column or row sum norm of the balanced matrix A; +C abssum = column sum norm of the balanced matrix B or row sum +C norm of the balanced matrix C. +C +C The routine is BASE dependent. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01HD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, October 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balanced form, orthogonal transformation, similarity +C transformation, state-space model, state-space representation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IGH, INFO, LDA, LDB, LDC, LDD, LOW, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), SCIN(*), SCOUT(*), SCSTAT(*) +C .. Local Scalars .. + INTEGER I, J, K, KNEW, KOLD + DOUBLE PRECISION ACNORM, ARNORM, SCALE +C .. External Functions .. + DOUBLE PRECISION DLANGE + EXTERNAL DLANGE +C .. External Subroutines .. + EXTERNAL DGEBAL, DSCAL, DSWAP, TB01TY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -11 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01TD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) THEN + LOW = 1 + IGH = N + RETURN + END IF +C +C Permute states, and balance a submatrix of A. +C + CALL DGEBAL( 'Both', N, A, LDA, LOW, IGH, SCSTAT, INFO ) +C +C Use the information in SCSTAT on state scalings and reorderings +C to transform B and C. +C + DO 10 K = 1, N + KOLD = K + IF ( ( LOW.GT.KOLD ) .OR. ( KOLD.GT.IGH ) ) THEN + IF ( KOLD.LT.LOW ) KOLD = LOW - KOLD + KNEW = INT( SCSTAT(KOLD) ) + IF ( KNEW.NE.KOLD ) THEN +C +C Exchange rows KOLD and KNEW of B. +C + CALL DSWAP( M, B(KOLD,1), LDB, B(KNEW,1), LDB ) +C +C Exchange columns KOLD and KNEW of C. +C + CALL DSWAP( P, C(1,KOLD), 1, C(1,KNEW), 1 ) + END IF + END IF + 10 CONTINUE +C + IF ( IGH.NE.LOW ) THEN +C + DO 20 K = LOW, IGH + SCALE = SCSTAT(K) +C +C Scale the K-th row of permuted B. +C + CALL DSCAL( M, ONE/SCALE, B(K,1), LDB ) +C +C Scale the K-th column of permuted C. +C + CALL DSCAL( P, SCALE, C(1,K), 1 ) + 20 CONTINUE +C + END IF +C +C Calculate the column and row sum norms of A. +C + ACNORM = DLANGE( '1-norm', N, N, A, LDA, DWORK ) + ARNORM = DLANGE( 'I-norm', N, N, A, LDA, DWORK ) +C +C Scale the columns of B (i.e. inputs) to have norms roughly ACNORM. +C + CALL TB01TY( 1, 0, 0, N, M, ACNORM, B, LDB, SCIN ) +C +C Scale the rows of C (i.e. outputs) to have norms roughly ARNORM. +C + CALL TB01TY( 0, 0, 0, P, N, ARNORM, C, LDC, SCOUT ) +C +C Finally, apply these input and output scalings to D and set SCIN. +C + DO 40 J = 1, M + SCALE = SCIN(J) +C + DO 30 I = 1, P + D(I,J) = D(I,J)*( SCALE*SCOUT(I) ) + 30 CONTINUE +C + SCIN(J) = ONE/SCALE + 40 CONTINUE +C + RETURN +C *** Last line of TB01TD *** + END diff --git a/mex/sources/libslicot/TB01TY.f b/mex/sources/libslicot/TB01TY.f new file mode 100644 index 000000000..6dada6fa4 --- /dev/null +++ b/mex/sources/libslicot/TB01TY.f @@ -0,0 +1,136 @@ + SUBROUTINE TB01TY( MODE, IOFF, JOFF, NROW, NCOL, SIZE, X, LDX, + $ BVECT ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Balances the rows (MODE .EQ. 0) or columns (MODE .NE. 0) of the +C (NROW x NCOL) block of the matrix X with offset (IOFF,JOFF), i.e. +C with first (top left) element (IOFF + 1,JOFF + 1). Each non- +C zero row (column) is balanced in the sense that it is multiplied +C by that integer power of the base of the machine floating-point +C representation for which the sum of the absolute values of its +C entries (i.e. its 1-norm) satisfies +C +C (SIZE / BASE) .LT. ABSSUM .LE. SIZE +C +C for SIZE as input. (Note that this form of scaling does not +C introduce any rounding errors.) The vector BVECT then contains +C the appropriate scale factors in rows (IOFF + 1)...(IOFF + NROW) +C (columns (JOFF + 1)...(JOFF + NCOL) ). In particular, if the +C I-th row (J-th column) of the block is 'numerically' non-zero +C with 1-norm given by BASE**(-EXPT) for some real EXPT, then the +C desired scale factor (returned as element IOFF + I (JOFF + J) of +C BVECT) is BASE**IEXPT, where IEXPT is the largest integer .LE. +C EXPT: this integer is precisely the truncation INT(EXPT) except +C for negative non-integer EXPT, in which case this value is too +C high by 1 and so must be adjusted accordingly. Finally, note +C that the element of BVECT corresponding to a 'numerically' zero +C row (column) is simply set equal to 1.0. +C +C For efficiency, no tests of the input scalar parameters are +C performed. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER IOFF, JOFF, LDX, MODE, NCOL, NROW + DOUBLE PRECISION SIZE +C .. Array Arguments .. + DOUBLE PRECISION BVECT(*), X(LDX,*) +C .. Local Scalars .. + DOUBLE PRECISION ABSSUM, DIV, EPS, EXPT, SCALE, TEST + INTEGER BASE, I, IEXPT, J +C .. External Functions .. + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH +C .. External Subroutines .. + EXTERNAL DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG +C .. Executable Statements .. +C + BASE = DLAMCH( 'Base' ) + EPS = DLAMCH( 'Epsilon' ) +C + DIV = ONE/LOG( DBLE( BASE ) ) + IF ( MODE.NE.0 ) THEN +C +C Balance one column at a time using its column-sum norm. +C + DO 10 J = JOFF + 1, JOFF + NCOL + ABSSUM = DASUM( NROW, X(IOFF+1,J), 1 )/ABS( SIZE ) + TEST = ABSSUM/DBLE( NROW ) + IF ( TEST.GT.EPS ) THEN +C +C Non-zero column: calculate (and apply) correct scale +C factor. +C + EXPT = -DIV*LOG( ABSSUM ) + IEXPT = INT( EXPT ) + IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) + $ IEXPT = IEXPT - 1 + SCALE = DBLE( BASE )**IEXPT + BVECT(J) = SCALE + CALL DSCAL( NROW, SCALE, X(IOFF+1,J), 1 ) + ELSE +C +C 'Numerically' zero column: do not rescale. +C + BVECT(J) = ONE + END IF + 10 CONTINUE +C + ELSE +C +C Balance one row at a time using its row-sum norm. +C + DO 20 I = IOFF + 1, IOFF + NROW + ABSSUM = DASUM( NCOL, X(I,JOFF+1), LDX )/ABS( SIZE ) + TEST = ABSSUM/DBLE( NCOL ) + IF ( TEST.GT.EPS ) THEN +C +C Non-zero row: calculate (and apply) correct scale factor. +C + EXPT = -DIV*LOG( ABSSUM ) + IEXPT = INT( EXPT ) + IF ( ( IEXPT.LT.0 ) .AND. ( DBLE( IEXPT ).NE.EXPT ) ) + $ IEXPT = IEXPT - 1 +C + SCALE = DBLE( BASE )**IEXPT + BVECT(I) = SCALE + CALL DSCAL( NCOL, SCALE, X(I,JOFF+1), LDX ) + ELSE +C +C 'Numerically' zero row: do not rescale. +C + BVECT(I) = ONE + END IF + 20 CONTINUE +C + END IF +C + RETURN +C *** Last line of TB01TY *** + END diff --git a/mex/sources/libslicot/TB01UD.f b/mex/sources/libslicot/TB01UD.f new file mode 100644 index 000000000..191780145 --- /dev/null +++ b/mex/sources/libslicot/TB01UD.f @@ -0,0 +1,491 @@ + SUBROUTINE TB01UD( JOBZ, N, M, P, A, LDA, B, LDB, C, LDC, NCONT, + $ INDCON, NBLK, Z, LDZ, TAU, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a controllable realization for the linear time-invariant +C multi-input system +C +C dX/dt = A * X + B * U, +C Y = C * X, +C +C where A, B, and C are N-by-N, N-by-M, and P-by-N matrices, +C respectively, and A and B are reduced by this routine to +C orthogonal canonical form using (and optionally accumulating) +C orthogonal similarity transformations, which are also applied +C to C. Specifically, the system (A, B, C) is reduced to the +C triplet (Ac, Bc, Cc), where Ac = Z' * A * Z, Bc = Z' * B, +C Cc = C * Z, with +C +C [ Acont * ] [ Bcont ] +C Ac = [ ], Bc = [ ], +C [ 0 Auncont ] [ 0 ] +C +C and +C +C [ A11 A12 . . . A1,p-1 A1p ] [ B1 ] +C [ A21 A22 . . . A2,p-1 A2p ] [ 0 ] +C [ 0 A32 . . . A3,p-1 A3p ] [ 0 ] +C Acont = [ . . . . . . . ], Bc = [ . ], +C [ . . . . . . ] [ . ] +C [ . . . . . ] [ . ] +C [ 0 0 . . . Ap,p-1 App ] [ 0 ] +C +C where the blocks B1, A21, ..., Ap,p-1 have full row ranks and +C p is the controllability index of the pair. The size of the +C block Auncont is equal to the dimension of the uncontrollable +C subspace of the pair (A, B). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal similarity transformations for +C reducing the system, as follows: +C = 'N': Do not form Z and do not store the orthogonal +C transformations; +C = 'F': Do not form Z, but store the orthogonal +C transformations in the factored form; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NCONT-by-NCONT part contains the +C upper block Hessenberg state dynamics matrix Acont in Ac, +C given by Z' * A * Z, of a controllable realization for +C the original system. The elements below the first block- +C subdiagonal are set to zero. The leading N-by-N part +C contains the matrix Ac. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading NCONT-by-M part of this array +C contains the transformed input matrix Bcont in Bc, given +C by Z' * B, with all elements but the first block set to +C zero. The leading N-by-M part contains the matrix Bc. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix Cc, given by C * Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NCONT (output) INTEGER +C The order of the controllable state-space representation. +C +C INDCON (output) INTEGER +C The controllability index of the controllable part of the +C system representation. +C +C NBLK (output) INTEGER array, dimension (N) +C The leading INDCON elements of this array contain the +C the orders of the diagonal blocks of Acont. +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C If JOBZ = 'I', then the leading N-by-N part of this +C array contains the matrix of accumulated orthogonal +C similarity transformations which reduces the given system +C to orthogonal canonical form. +C If JOBZ = 'F', the elements below the diagonal, with the +C array TAU, represent the orthogonal transformation matrix +C as a product of elementary reflectors. The transformation +C matrix can then be obtained by calling the LAPACK Library +C routine DORGQR. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'I' or +C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The elements of TAU contain the scalar factors of the +C elementary reflectors used in the reduction of B and A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N, 3*M, P). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Matrix B is first QR-decomposed and the appropriate orthogonal +C similarity transformation applied to the matrix A. Leaving the +C first rank(B) states unchanged, the remaining lower left block +C of A is then QR-decomposed and the new orthogonal matrix, Q1, +C is also applied to the right of A to complete the similarity +C transformation. By continuing in this manner, a completely +C controllable state-space pair (Acont, Bcont) is found for the +C given (A, B), where Acont is upper block Hessenberg with each +C subdiagonal block of full row rank, and Bcont is zero apart from +C its (independent) first rank(B) rows. +C All orthogonal transformations determined in this process are also +C applied to the matrix C, from the right. +C NOTE that the system controllability indices are easily +C calculated from the dimensions of the blocks of Acont. +C +C REFERENCES +C +C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. +C Orthogonal Invariants and Canonical Forms for Linear +C Controllable Systems. +C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. +C +C [2] Paige, C.C. +C Properties of numerical algorithms related to computing +C controllablity. +C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. +C +C [3] Petkov, P.Hr., Konstantinov, M.M., Gu, D.W. and +C Postlethwaite, I. +C Optimal Pole Assignment Design of Linear Multi-Input Systems. +C Leicester University, Report 99-11, May 1996. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C FURTHER COMMENTS +C +C If the system matrices A and B are badly scaled, it would be +C useful to scale them with SLICOT routine TB01ID, before calling +C the routine. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Katholieke Univ. Leuven, Belgium, May 1999, Nov. 2003. +C A. Varga, DLR Oberpfaffenhofen, March 2002, Nov. 2003. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INDCON, INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N, + $ NCONT, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), TAU(*), + $ Z(LDZ,*) + INTEGER IWORK(*), NBLK(*) +C .. Local Scalars .. + LOGICAL LJOBF, LJOBI, LJOBZ + INTEGER IQR, ITAU, J, MCRT, NBL, NCRT, NI, NJ, RANK, + $ WRKOPT + DOUBLE PRECISION ANORM, BNORM, FNRM, TOLDEF +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2 + EXTERNAL DLAMCH, DLANGE, DLAPY2, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAPMT, DLASET, DORGQR, DORMQR, + $ MB01PD, MB03OY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C + INFO = 0 + LJOBF = LSAME( JOBZ, 'F' ) + LJOBI = LSAME( JOBZ, 'I' ) + LJOBZ = LJOBF.OR.LJOBI +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( .NOT.LJOBZ .AND. LDZ.LT.1 .OR. + $ LJOBZ .AND. LDZ.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDWORK.LT.MAX( 1, N, 3*M, P ) ) THEN + INFO = -20 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01UD', -INFO ) + RETURN + END IF +C + NCONT = 0 + INDCON = 0 +C +C Calculate the absolute norms of A and B (used for scaling). +C + ANORM = DLANGE( 'M', N, N, A, LDA, DWORK ) + BNORM = DLANGE( 'M', N, M, B, LDB, DWORK ) +C +C Quick return if possible. +C + IF ( MIN( N, M ).EQ.0 .OR. BNORM.EQ.ZERO ) THEN + IF( N.GT.0 ) THEN + IF ( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + ELSE IF ( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + END IF + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Scale (if needed) the matrices A and B. +C + CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) + CALL MB01PD( 'S', 'G', N, M, 0, 0, BNORM, 0, NBLK, B, LDB, INFO ) +C +C Compute the Frobenius norm of [ B A ] (used for rank estimation). +C + FNRM = DLAPY2( DLANGE( 'F', N, M, B, LDB, DWORK ), + $ DLANGE( 'F', N, N, A, LDA, DWORK ) ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + TOLDEF = DBLE( N*N )*DLAMCH( 'EPSILON' ) + END IF +C + IF ( FNRM.LT.TOLDEF ) + $ FNRM = ONE +C + WRKOPT = 1 + NI = 0 + ITAU = 1 + NCRT = N + MCRT = M + IQR = 1 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + 10 CONTINUE +C +C Rank-revealing QR decomposition with column pivoting. +C The calculation is performed in NCRT rows of B starting from +C the row IQR (initialized to 1 and then set to rank(B)+1). +C Workspace: 3*MCRT. +C + CALL MB03OY( NCRT, MCRT, B(IQR,1), LDB, TOLDEF, FNRM, RANK, + $ SVAL, IWORK, TAU(ITAU), DWORK, INFO ) +C + IF ( RANK.NE.0 ) THEN + NJ = NI + NI = NCONT + NCONT = NCONT + RANK + INDCON = INDCON + 1 + NBLK(INDCON) = RANK +C +C Premultiply and postmultiply the appropriate block row +C and block column of A by Q' and Q, respectively. +C Workspace: need NCRT; +C prefer NCRT*NB. +C + CALL DORMQR( 'Left', 'Transpose', NCRT, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), A(NI+1,NI+1), LDA, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Workspace: need N; +C prefer N*NB. +C + CALL DORMQR( 'Right', 'No transpose', N, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), A(1,NI+1), LDA, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C Postmultiply the appropriate block column of C by Q. +C Workspace: need P; +C prefer P*NB. +C + CALL DORMQR( 'Right', 'No transpose', P, NCRT, RANK, + $ B(IQR,1), LDB, TAU(ITAU), C(1,NI+1), LDC, + $ DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) +C +C If required, save transformations. +C + IF ( LJOBZ.AND.NCRT.GT.1 ) THEN + CALL DLACPY( 'L', NCRT-1, MIN( RANK, NCRT-1 ), + $ B(IQR+1,1), LDB, Z(NI+2,ITAU), LDZ ) + END IF +C +C Zero the subdiagonal elements of the current matrix. +C + IF ( RANK.GT.1 ) + $ CALL DLASET( 'L', RANK-1, RANK-1, ZERO, ZERO, B(IQR+1,1), + $ LDB ) +C +C Backward permutation of the columns of B or A. +C + IF ( INDCON.EQ.1 ) THEN + CALL DLAPMT( .FALSE., RANK, M, B(IQR,1), LDB, IWORK ) + IQR = RANK + 1 + ELSE + DO 20 J = 1, MCRT + CALL DCOPY( RANK, B(IQR,J), 1, A(NI+1,NJ+IWORK(J)), + $ 1 ) + 20 CONTINUE + END IF +C + ITAU = ITAU + RANK + IF ( RANK.NE.NCRT ) THEN + MCRT = RANK + NCRT = NCRT - RANK + CALL DLACPY( 'G', NCRT, MCRT, A(NCONT+1,NI+1), LDA, + $ B(IQR,1), LDB ) + CALL DLASET( 'G', NCRT, MCRT, ZERO, ZERO, + $ A(NCONT+1,NI+1), LDA ) + GO TO 10 + END IF + END IF +C +C If required, accumulate transformations. +C Workspace: need N; prefer N*NB. +C + IF ( LJOBI ) THEN + CALL DORGQR( N, N, ITAU-1, Z, LDZ, TAU, DWORK, + $ LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) ) + END IF +C +C Annihilate the trailing blocks of B. +C + IF( IQR.LE.N ) + $ CALL DLASET( 'G', N-IQR+1, M, ZERO, ZERO, B(IQR,1), LDB ) +C +C Annihilate the trailing elements of TAU, if JOBZ = 'F'. +C + IF ( LJOBF ) THEN + DO 30 J = ITAU, N + TAU(J) = ZERO + 30 CONTINUE + END IF +C +C Undo scaling of A and B. +C + IF ( INDCON.LT.N ) THEN + NBL = INDCON + 1 + NBLK(NBL) = N - NCONT + ELSE + NBL = 0 + END IF + CALL MB01PD( 'U', 'H', N, N, 0, 0, ANORM, NBL, NBLK, A, LDA, + $ INFO ) + CALL MB01PD( 'U', 'G', NBLK(1), M, 0, 0, BNORM, 0, NBLK, B, LDB, + $ INFO ) +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of TB01UD *** + END diff --git a/mex/sources/libslicot/TB01VD.f b/mex/sources/libslicot/TB01VD.f new file mode 100644 index 000000000..26cd1c7c3 --- /dev/null +++ b/mex/sources/libslicot/TB01VD.f @@ -0,0 +1,503 @@ + SUBROUTINE TB01VD( APPLY, N, M, L, A, LDA, B, LDB, C, LDC, D, LDD, + $ X0, THETA, LTHETA, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To convert the linear discrete-time system given as (A, B, C, D), +C with initial state x0, into the output normal form [1], with +C parameter vector THETA. The matrix A is assumed to be stable. +C The matrices A, B, C, D and the vector x0 are converted, so that +C on exit they correspond to the system defined by THETA. +C +C ARGUMENTS +C +C Mode Parameters +C +C APPLY CHARACTER*1 +C Specifies whether or not the parameter vector should be +C transformed using a bijective mapping, as follows: +C = 'A' : apply the bijective mapping to the N vectors in +C THETA corresponding to the matrices A and C; +C = 'N' : do not apply the bijective mapping. +C The transformation performed when APPLY = 'A' allows +C to get rid of the constraints norm(THETAi) < 1, i = 1:N. +C A call of the SLICOT Library routine TB01VY associated to +C a call of TB01VD must use the same value of APPLY. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A, assumed to be stable. +C On exit, the leading N-by-N part of this array contains +C the transformed system state matrix corresponding to the +C output normal form with parameter vector THETA. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed system input matrix corresponding to the +C output normal form with parameter vector THETA. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading L-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading L-by-N part of this array contains +C the transformed system output matrix corresponding to the +C output normal form with parameter vector THETA. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,L). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading L-by-M part of this array must contain the +C system input/output matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,L). +C +C X0 (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state of the +C system, x0. +C On exit, this array contains the transformed initial state +C of the system, corresponding to the output normal form +C with parameter vector THETA. +C +C THETA (output) DOUBLE PRECISION array, dimension (LTHETA) +C The leading N*(L+M+1)+L*M part of this array contains the +C parameter vector that defines a system (A, B, C, D, x0) +C which is equivalent up to a similarity transformation to +C the system given on entry. The parameters are: +C +C THETA(1:N*L) : parameters for A, C; +C THETA(N*L+1:N*(L+M)) : parameters for B; +C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; +C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. +C +C LTHETA INTEGER +C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*N*L + N*L + N, +C N*N + MAX(N*N + N*MAX(N,L) + 6*N + MIN(N,L), +C N*M)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the Lyapunov equation A'*Q*A - Q = -scale^2*C'*C +C could only be solved with scale = 0; +C = 2: if matrix A is not discrete-time stable; +C = 3: if the QR algorithm failed to converge for +C matrix A. +C +C METHOD +C +C The matrices A and C are converted to output normal form. +C First, the Lyapunov equation +C +C A'*Q*A - Q = -scale^2*C'*C, +C +C is solved in the Cholesky factor T, T'*T = Q, and then T is used +C to get the transformation matrix. +C +C The matrix B and the initial state x0 are transformed accordingly. +C +C Then, the QR factorization of the transposed observability matrix +C is computed, and the matrix Q is used to further transform the +C system matrices. The parameters characterizing A and C are finally +C obtained by applying a set of N orthogonal transformations. +C +C REFERENCES +C +C [1] Peeters, R.L.M., Hanzon, B., and Olivi, M. +C Balanced realizations of discrete-time stable all-pass +C systems and the tangential Schur algorithm. +C Proceedings of the European Control Conference, +C 31 August - 3 September 1999, Karlsruhe, Germany. +C Session CP-6, Discrete-time Systems, 1999. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Feb. 2002, Feb. 2004. +C +C KEYWORDS +C +C Asymptotically stable, Lyapunov equation, output normal form, +C parameter estimation, similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER APPLY + INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, + $ N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), THETA(*), X0(*) +C .. Local Scalars .. + DOUBLE PRECISION PIBY2, RI, SCALE, TI + INTEGER CA, I, IA, IN, IQ, IR, IT, ITAU, IU, IWI, IWR, + $ J, JWORK, K, LDCA, LDT, WRKOPT + LOGICAL LAPPLY +C .. External Functions .. + EXTERNAL DNRM2, LSAME + DOUBLE PRECISION DNRM2 + LOGICAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGEQRF, DGER, + $ DLACPY, DLASET, DORMQR, DSCAL, DTRMM, DTRMV, + $ DTRSM, MA02AD, SB03OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, INT, MAX, MIN, SQRT, TAN +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + LAPPLY = LSAME( APPLY, 'A' ) +C + INFO = 0 + IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( N.LT.0 ) THEN + INFO = -2 + ELSEIF ( M.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.LT.0 ) THEN + INFO = -4 + ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN + INFO = -10 + ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN + INFO = -12 + ELSEIF ( LTHETA.LT.( N*( M + L + 1 ) + L*M ) ) THEN + INFO = -15 + ELSEIF ( LDWORK.LT.MAX( 1, N*N*L + N*L + N, N*N + + $ MAX( N*( N + MAX( N, L ) + 6 ) + + $ MIN( N, L ), N*M ) ) ) THEN + INFO = -17 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TB01VD', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MAX( N, M, L ).EQ.0 ) THEN + DWORK(1) = ONE + RETURN + ELSE IF ( N.EQ.0 ) THEN + CALL DLACPY( 'Full', L, M, D, LDD, THETA, MAX( 1, L ) ) + DWORK(1) = ONE + RETURN + ELSE IF ( L.EQ.0 ) THEN + CALL DLACPY( 'Full', N, M, B, LDB, THETA, N ) + CALL DCOPY( N, X0, 1, THETA(N*M+1), 1 ) + DWORK(1) = ONE + RETURN + ENDIF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = 1 + PIBY2 = TWO*ATAN( ONE ) +C +C Convert A and C to output normal form. +C First, solve the Lyapunov equation +C A'*Q*A - Q = -scale^2*C'*C, +C in the Cholesky factor T, T'*T = Q, and use T to get the +C transformation matrix. Copy A and C, to preserve them. +C +C Workspace: need N*(2*N + MAX(N,L) + 6) + MIN(N,L). +C prefer larger. +C +C Initialize the indices in the workspace. +C + LDT = MAX( N, L ) + CA = 1 + IA = 1 + IT = IA + N*N + IU = IT + LDT*N + IWR = IU + N*N + IWI = IWR + N +C + JWORK = IWI + N +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IT), LDT ) +C + CALL SB03OD( 'Discrete', 'NotFactored', 'NoTranspose', N, L, + $ DWORK(IA), N, DWORK(IU), N, DWORK(IT), LDT, SCALE, + $ DWORK(IWR), DWORK(IWI), DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + IF ( INFO.NE.0 ) THEN + IF ( INFO.EQ.6 ) THEN + INFO = 3 + ELSE + INFO = 2 + ENDIF + RETURN + ENDIF + WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 +C + IF ( SCALE.EQ.ZERO ) THEN + INFO = 1 + RETURN + ENDIF +C +C Compute A = T*A*T^(-1). +C + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, + $ DWORK(IT), LDT, A, LDA ) +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', N, N, ONE, + $ DWORK(IT), LDT, A, LDA ) + IF ( M.GT.0 ) THEN +C +C Compute B = (1/scale)*T*B. +C + CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', N, M, + $ ONE/SCALE, DWORK(IT), LDT, B, LDB ) + ENDIF +C +C Compute x0 = (1/scale)*T*x0. +C + CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', N, DWORK(IT), LDT, + $ X0, 1 ) + CALL DSCAL( N, ONE/SCALE, X0, 1 ) +C +C Compute C = scale*C*T^(-1). +C + CALL DTRSM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', L, N, + $ SCALE, DWORK(IT), LDT, C, LDC ) +C +C Now, the system has been transformed to the output normal form. +C Build the transposed observability matrix in DWORK(CA) and compute +C its QR factorization. +C + CALL MA02AD( 'Full', L, N, C, LDC, DWORK(CA), N ) +C + DO 10 I = 1, N - 1 + CALL DGEMM( 'Transpose', 'NoTranspose', N, L, N, ONE, A, LDA, + $ DWORK(CA+(I-1)*N*L), N, ZERO, DWORK(CA+I*N*L), N ) + 10 CONTINUE +C +C Compute the QR factorization. +C +C Workspace: need N*N*L + N + L*N. +C prefer N*N*L + N + NB*L*N. +C + ITAU = CA + N*N*L + JWORK = ITAU + N + CALL DGEQRF( N, L*N, DWORK(CA), N, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) +C +C Compute Q such that R has all diagonal elements nonnegative. +C Only the first N*N part of R is needed. Move the details +C of the QR factorization process, to gain memory and efficiency. +C +C Workspace: need 2*N*N + 2*N. +C prefer 2*N*N + N + NB*N. +C + IR = N*N + 1 + IF ( L.NE.2 ) + $ CALL DCOPY( N, DWORK(ITAU), 1, DWORK(IR+N*N), 1 ) + CALL DLACPY( 'Lower', N, N, DWORK(CA), N, DWORK(IR), N ) + ITAU = IR + N*N + JWORK = ITAU + N +C + IQ = 1 + CALL DLASET( 'Full', N, N, ZERO, ONE, DWORK(IQ), N ) +C + DO 20 I = 1, N + IF ( DWORK(IR+(I-1)*(N+1)).LT.ZERO ) + $ DWORK(IQ+(I-1)*(N+1))= -ONE + 20 CONTINUE +C + CALL DORMQR( 'Left', 'NoTranspose', N, N, N, DWORK(IR), N, + $ DWORK(ITAU), DWORK(IQ), N, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 ) + JWORK = IR +C +C Now, the transformation matrix Q is in DWORK(IQ). +C +C Compute A = Q'*A*Q. +C + CALL DGEMM( 'Transpose', 'NoTranspose', N, N, N, ONE, DWORK(IQ), + $ N, A, LDA, ZERO, DWORK(JWORK), N ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE, + $ DWORK(JWORK), N, DWORK(IQ), N, ZERO, A, LDA ) +C + IF ( M.GT.0 ) THEN +C +C Compute B = Q'*B. +C Workspace: need N*N + N*M. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK(JWORK), N ) + CALL DGEMM( 'Transpose', 'NoTranspose', N, M, N, ONE, + $ DWORK(IQ), N, DWORK(JWORK), N, ZERO, B, LDB ) + ENDIF +C +C Compute C = C*Q. +C Workspace: need N*N + N*L. +C + CALL DLACPY( 'Full', L, N, C, LDC, DWORK(JWORK), L ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', L, N, N, ONE, + $ DWORK(JWORK), L, DWORK(IQ), N, ZERO, C, LDC ) +C +C Compute x0 = Q'*x0. +C + CALL DCOPY( N, X0, 1, DWORK(JWORK), 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, DWORK(IQ), N, DWORK(JWORK), + $ 1, ZERO, X0, 1 ) +C +C Now, copy C and A into the workspace to make it easier to read out +C the corresponding part of THETA, and to apply the transformations. +C + LDCA = N + L +C + DO 30 I = 1, N + CALL DCOPY( L, C(1,I), 1, DWORK(CA+(I-1)*LDCA), 1 ) + CALL DCOPY( N, A(1,I), 1, DWORK(CA+L+(I-1)*LDCA), 1 ) + 30 CONTINUE +C + JWORK = CA + LDCA*N +C +C The parameters characterizing A and C are extracted in this loop. +C Workspace: need N*(N + L + 1). +C + DO 60 I = 1, N + CALL DCOPY( L, DWORK(CA+1+(N-I)*(LDCA+1)), 1, THETA((I-1)*L+1), + $ 1 ) + RI = DWORK(CA+(N-I)*(LDCA+1)) + TI = DNRM2( L, THETA((I-1)*L+1), 1 ) +C +C Multiply the part of [C; A] which will be currently transformed +C with Ui = [ -THETAi, Si; RI, THETAi' ] from the left, without +C storing Ui. Ui has the size (L+1)-by-(L+1). +C + CALL DGEMV( 'Transpose', L, N, ONE, DWORK(CA+N-I+1), LDCA, + $ THETA((I-1)*L+1), 1, ZERO, DWORK(JWORK), 1 ) +C + IF ( TI.GT.ZERO ) THEN + CALL DGER( L, N, (RI-ONE)/TI/TI, THETA((I-1)*L+1), 1, + $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) + ELSE +C +C The call below is for the limiting case. +C + CALL DGER( L, N, -HALF, THETA((I-1)*L+1), 1, + $ DWORK(JWORK), 1, DWORK(CA+N-I+1), LDCA ) + ENDIF +C + CALL DGER( L, N, -ONE, THETA((I-1)*L+1), 1, DWORK(CA+N-I), + $ LDCA, DWORK(CA+N-I+1), LDCA ) + CALL DAXPY( N, RI, DWORK(CA+N-I), LDCA, DWORK(JWORK), 1 ) +C +C Move these results to their appropriate locations. +C + DO 50 J = 1, N + IN = CA + N - I + ( J - 1 )*LDCA + DO 40 K = IN + 1, IN + L + DWORK(K-1) = DWORK(K) + 40 CONTINUE + DWORK(IN+L) = DWORK(JWORK+J-1) + 50 CONTINUE +C +C Now, apply the bijective mapping, which allows to get rid +C of the constraint norm(THETAi) < 1. +C + IF ( LAPPLY .AND. TI.NE.ZERO ) + $ CALL DSCAL( L, TAN( TI*PIBY2 )/TI, THETA((I-1)*L+1), 1 ) +C + 60 CONTINUE +C + IF ( M.GT.0 ) THEN +C +C The next part of THETA is B. +C + CALL DLACPY( 'Full', N, M, B, LDB, THETA(N*L+1), N ) +C +C Copy the matrix D. +C + CALL DLACPY( 'Full', L, M, D, LDD, THETA(N*(L+M)+1), L ) + ENDIF +C +C Copy the initial state x0. +C + CALL DCOPY( N, X0, 1, THETA(N*(L+M)+L*M+1), 1 ) +C + DWORK(1) = WRKOPT + RETURN +C +C *** Last line of TB01VD *** + END diff --git a/mex/sources/libslicot/TB01VY.f b/mex/sources/libslicot/TB01VY.f new file mode 100644 index 000000000..d18361a20 --- /dev/null +++ b/mex/sources/libslicot/TB01VY.f @@ -0,0 +1,317 @@ + SUBROUTINE TB01VY( APPLY, N, M, L, THETA, LTHETA, A, LDA, B, LDB, + $ C, LDC, D, LDD, X0, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To convert the linear discrete-time system given as its output +C normal form [1], with parameter vector THETA, into the state-space +C representation (A, B, C, D), with the initial state x0. +C +C ARGUMENTS +C +C Mode Parameters +C +C APPLY CHARACTER*1 +C Specifies whether or not the parameter vector should be +C transformed using a bijective mapping, as follows: +C = 'A' : apply the bijective mapping to the N vectors in +C THETA corresponding to the matrices A and C; +C = 'N' : do not apply the bijective mapping. +C The transformation performed when APPLY = 'A' allows +C to get rid of the constraints norm(THETAi) < 1, i = 1:N. +C A call of the SLICOT Library routine TB01VD associated to +C a call of TB01VY must use the same value of APPLY. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C L (input) INTEGER +C The number of system outputs. L >= 0. +C +C THETA (input) DOUBLE PRECISION array, dimension (LTHETA) +C The leading N*(L+M+1)+L*M part of this array must contain +C the parameter vector that defines a system (A, B, C, D), +C with the initial state x0. The parameters are: +C +C THETA(1:N*L) : parameters for A, C; +C THETA(N*L+1:N*(L+M)) : parameters for B; +C THETA(N*(L+M)+1:N*(L+M)+L*M) : parameters for D; +C THETA(N*(L+M)+L*M+1:N*(L+M+1)+L*M): parameters for x0. +C +C LTHETA INTEGER +C The length of array THETA. LTHETA >= N*(L+M+1)+L*M. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the system +C state matrix corresponding to the output normal form with +C parameter vector THETA. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array contains the system +C input matrix corresponding to the output normal form with +C parameter vector THETA. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading L-by-N part of this array contains the system +C output matrix corresponding to the output normal form with +C parameter vector THETA. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,L). +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading L-by-M part of this array contains the system +C input/output matrix corresponding to the output normal +C form with parameter vector THETA. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,L). +C +C X0 (output) DOUBLE PRECISION array, dimension (N) +C This array contains the initial state of the system, x0, +C corresponding to the output normal form with parameter +C vector THETA. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= N*(N+L+1). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The parameters characterizing A and C are used to build N +C orthogonal transformations, which are then applied to recover +C these matrices. +C +C CONTRIBUTORS +C +C A. Riedel, R. Schneider, Chemnitz University of Technology, +C Oct. 2000, during a stay at University of Twente, NL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001, +C Feb. 2002, Feb. 2004. +C +C KEYWORDS +C +C Asymptotically stable, output normal form, parameter estimation, +C similarity transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, HALF = 0.5D0 ) +C .. Scalar Arguments .. + CHARACTER APPLY + INTEGER INFO, L, LDA, LDB, LDC, LDD, LDWORK, LTHETA, M, + $ N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), THETA(*), X0(*) +C .. Local Scalars .. + DOUBLE PRECISION FACTOR, RI, TI, TOBYPI + INTEGER CA, JWORK, I, IN, J, K, LDCA + LOGICAL LAPPLY +C .. External Functions .. + EXTERNAL DNRM2, LSAME + DOUBLE PRECISION DNRM2 + LOGICAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLACPY, DSCAL, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC ATAN, MAX, SQRT +C .. +C .. Executable Statements .. +C +C Check the scalar input parameters. +C + LAPPLY = LSAME( APPLY, 'A' ) +C + INFO = 0 + IF ( .NOT.( LAPPLY .OR. LSAME( APPLY, 'N' ) ) ) THEN + INFO = -1 + ELSEIF ( N.LT.0 ) THEN + INFO = -2 + ELSEIF ( M.LT.0 ) THEN + INFO = -3 + ELSEIF ( L.LT.0 ) THEN + INFO = -4 + ELSEIF ( LTHETA.LT.( N*( L + M + 1 ) + L*M ) ) THEN + INFO = -6 + ELSEIF ( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSEIF ( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSEIF ( LDC.LT.MAX( 1, L ) ) THEN + INFO = -12 + ELSEIF ( LDD.LT.MAX( 1, L ) ) THEN + INFO = -14 + ELSEIF ( LDWORK.LT.N*( N + L + 1 ) ) THEN + INFO = -17 + ENDIF +C +C Return if there are illegal arguments. +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TB01VY', -INFO ) + RETURN + ENDIF +C +C Quick return if possible. +C + IF ( MAX( N, M, L ).EQ.0 ) + $ RETURN +C + IF ( M.GT.0 ) THEN +C +C Copy the matrix B from THETA. +C + CALL DLACPY( 'Full', N, M, THETA(N*L+1), N, B, LDB ) +C +C Copy the matrix D. +C + CALL DLACPY( 'Full', L, M, THETA(N*(L+M)+1), L, D, LDD ) + ENDIF +C + IF ( N.EQ.0 ) THEN + RETURN + ELSE IF ( L.EQ.0 ) THEN + CALL DCOPY( N, THETA(N*M+1), 1, X0, 1 ) + RETURN + END IF +C +C Initialize the indices in the workspace. +C + LDCA = N + L +C + CA = 1 +C + JWORK = CA + N*LDCA + TOBYPI = HALF/ATAN( ONE ) +C +C Generate the matrices C and A from their parameters. +C Start with the block matrix [0; I], where 0 is a block of zeros +C of size L-by-N, and I is the identity matrix of order N. +C + DWORK(CA) = ZERO + CALL DCOPY( N*(L+N), DWORK(CA), 0, DWORK(CA), 1 ) + DWORK(CA+L) = ONE + CALL DCOPY( N, DWORK(CA+L), 0, DWORK(CA+L), LDCA+1 ) +C +C Now, read out THETA(1 : N*L) and perform the transformations +C defined by the parameters in THETA. +C + DO 30 I = N, 1, -1 +C +C Save THETAi in the first column of C and use the copy for +C further processing. +C + CALL DCOPY( L, THETA((I-1)*L+1), 1, C, 1 ) + TI = DNRM2( L, C, 1 ) + IF ( LAPPLY .AND. TI.NE.ZERO ) THEN +C +C Apply the bijective mapping which guarantees that TI < 1. +C + FACTOR = TOBYPI*ATAN( TI )/TI +C +C Scale THETAi and apply the same scaling on TI. +C + CALL DSCAL( L, FACTOR, C, 1 ) + TI = TI*FACTOR + END IF +C +C RI = sqrt( 1 - TI**2 ). +C + RI = SQRT( ( ONE - TI )*( ONE + TI ) ) +C +C Multiply a certain part of DWORK(CA) with Ui' from the left, +C where Ui = [ -THETAi, Si; RI, THETAi' ] is (L+1)-by-(L+1), but +C Ui is not stored. +C + CALL DGEMV( 'Transpose', L, N, -ONE, DWORK(CA+N-I), LDCA, C, 1, + $ ZERO, DWORK(JWORK), 1 ) +C + IF ( TI.GT.ZERO ) THEN + CALL DGER( L, N, (ONE-RI)/TI/TI, C, 1, DWORK(JWORK), 1, + $ DWORK(CA+N-I), LDCA ) + ELSE +C +C The call below is for the limiting case. +C + CALL DGER( L, N, HALF, C, 1, DWORK(JWORK), 1, + $ DWORK(CA+N-I), LDCA ) + ENDIF +C + CALL DGER( L, N, ONE, C, 1, DWORK(CA+N-I+L), LDCA, + $ DWORK(CA+N-I), LDCA ) + CALL DAXPY( N, RI, DWORK(CA+N-I+L), LDCA, DWORK(JWORK), 1 ) +C +C Move these results to their appropriate locations. +C + DO 20 J = 1, N + IN = CA + N - I + ( J - 1 )*LDCA + DO 10 K = IN + L, IN + 1, -1 + DWORK(K) = DWORK(K-1) + 10 CONTINUE + DWORK(IN) = DWORK(JWORK+J-1) + 20 CONTINUE +C + 30 CONTINUE +C +C Now, DWORK(CA) = [C; A]. Copy to C and A. +C + DO 40 I = 1, N + CALL DCOPY( L, DWORK(CA+(I-1)*LDCA), 1, C(1,I), 1 ) + CALL DCOPY( N, DWORK(CA+L+(I-1)*LDCA), 1, A(1,I), 1 ) + 40 CONTINUE +C +C Copy the initial state x0. +C + CALL DCOPY( N, THETA(N*(L+M)+L*M+1), 1, X0, 1 ) +C + RETURN +C +C *** Last line of TB01VY *** + END diff --git a/mex/sources/libslicot/TB01WD.f b/mex/sources/libslicot/TB01WD.f new file mode 100644 index 000000000..36dd01231 --- /dev/null +++ b/mex/sources/libslicot/TB01WD.f @@ -0,0 +1,259 @@ + SUBROUTINE TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU, + $ WR, WI, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the system state matrix A to an upper real Schur form +C by using an orthogonal similarity transformation A <-- U'*A*U and +C to apply the transformation to the matrices B and C: B <-- U'*B +C and C <-- C*U. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix U' * A * U in real Schur form. The elements +C below the first subdiagonal are set to zero. +C Note: A matrix is in real Schur form if it is upper +C quasi-triangular with 1-by-1 and 2-by-2 blocks. +C 2-by-2 blocks are standardized in the form +C [ a b ] +C [ c a ] +C where b*c < 0. The eigenvalues of such a block +C are a +- sqrt(bc). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix U' * B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * U. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C U (output) DOUBLE PRECISION array, dimension (LDU,N) +C The leading N-by-N part of this array contains the +C orthogonal transformation matrix used to reduce A to the +C real Schur form. The columns of U are the Schur vectors of +C matrix A. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= max(1,N). +C +C WR, WI (output) DOUBLE PRECISION arrays, dimension (N) +C WR and WI contain the real and imaginary parts, +C respectively, of the computed eigenvalues of A. The +C eigenvalues will be in the same order that they appear on +C the diagonal of the output real Schur form of A. Complex +C conjugate pairs of eigenvalues will appear consecutively +C with the eigenvalue having the positive imaginary part +C first. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. LWORK >= 3*N. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QR algorithm failed to compute +C all the eigenvalues; elements i+1:N of WR and WI +C contain those eigenvalues which have converged; +C U contains the matrix which reduces A to its +C partially converged Schur form. +C +C METHOD +C +C Matrix A is reduced to a real Schur form using an orthogonal +C similarity transformation A <- U'*A*U. Then, the transformation +C is applied to the matrices B and C: B <-- U'*B and C <-- C*U. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires about 10N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, March 1998. +C Based on the RASP routine SRSFDC. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Orthogonal transformation, real Schur form, similarity +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*), + $ WI(*), WR(*) +C .. Local Scalars .. + INTEGER I, LDWP, SDIM + DOUBLE PRECISION WRKOPT +C .. Local Arrays .. + LOGICAL BWORK( 1 ) +C .. External Functions .. + LOGICAL LSAME, SELECT + EXTERNAL LSAME, SELECT +C .. External Subroutines .. + EXTERNAL DCOPY, DGEES, DGEMM, DGEMV, DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check input parameters. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( LDU.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.3*N ) THEN + INFO = -15 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) + $ RETURN +C +C Reduce A to real Schur form using an orthogonal similarity +C transformation A <- U'*A*U, accumulate the transformation in U +C and compute the eigenvalues of A in (WR,WI). +C +C Workspace: need 3*N; +C prefer larger. +C + CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM, + $ WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO ) + WRKOPT = DWORK( 1 ) + IF( INFO.NE.0 ) + $ RETURN +C +C Apply the transformation: B <-- U'*B. +C + IF( LDWORK.LT.N*M ) THEN +C +C Not enough working space for using DGEMM. +C + DO 10 I = 1, M + CALL DCOPY( N, B(1,I), 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ B(1,I), 1 ) + 10 CONTINUE +C + ELSE + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU, + $ DWORK, N, ZERO, B, LDB ) + WRKOPT = MAX( WRKOPT, DBLE( N*M ) ) + END IF +C +C Apply the transformation: C <-- C*U. +C + IF( LDWORK.LT.N*P ) THEN +C +C Not enough working space for using DGEMM. +C + DO 20 I = 1, P + CALL DCOPY( N, C(I,1), LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO, + $ C(I,1), LDC ) + 20 CONTINUE +C + ELSE + LDWP = MAX( 1, P ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP ) + CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, + $ DWORK, LDWP, U, LDU, ZERO, C, LDC ) + WRKOPT = MAX( WRKOPT, DBLE( N*P ) ) + END IF +C + DWORK( 1 ) = WRKOPT +C + RETURN +C *** Last line of TB01WD *** + END diff --git a/mex/sources/libslicot/TB01XD.f b/mex/sources/libslicot/TB01XD.f new file mode 100644 index 000000000..78bf92957 --- /dev/null +++ b/mex/sources/libslicot/TB01XD.f @@ -0,0 +1,284 @@ + SUBROUTINE TB01XD( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, + $ D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a special transformation to a system given as a triple +C (A,B,C), +C +C A <-- P * A' * P, B <-- P * C', C <-- B' * P, +C +C where P is a matrix with 1 on the secondary diagonal, and with 0 +C in the other entries. Matrix A can be specified as a band matrix. +C Optionally, matrix D of the system can be transposed. This +C transformation is actually a special similarity transformation of +C the dual system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C KL (input) INTEGER +C The number of subdiagonals of A to be transformed. +C MAX( 0, N-1 ) >= KL >= 0. +C +C KU (input) INTEGER +C The number of superdiagonals of A to be transformed. +C MAX( 0, N-1 ) >= KU >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed (pertransposed) matrix P*A'*P. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, the leading N-by-P part of this array contains +C the dual input/state matrix P*C'. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0 or P > 0. +C LDB >= 1 if M = 0 and P = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, the leading M-by-N part of this array contains +C the dual state/output matrix B'*P. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) DOUBLE PRECISION array, dimension +C (LDD,MAX(M,P)) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the original direct transmission +C matrix D. +C On exit, if JOBD = 'D', the leading M-by-P part of this +C array contains the transposed direct transmission matrix +C D'. The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,M,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The rows and/or columns of the matrices of the triplet (A,B,C) +C and, optionally, of the matrix D are swapped in a special way. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C Partly based on routine DMPTR (A. Varga, German Aerospace +C Research Establishment, DLR, Aug. 1992). +C +C +C REVISIONS +C +C 07-31-1998, 04-25-1999, A. Varga. +C 03-16-2004, V. Sima. +C +C KEYWORDS +C +C Matrix algebra, matrix operations, similarity transformation. +C +C ********************************************************************* +C +C .. +C .. Scalar Arguments .. + CHARACTER JOBD + INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ) +C .. +C .. Local Scalars .. + LOGICAL LJOBD + INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 +C .. +C .. External functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 + LJOBD = LSAME( JOBD, 'D' ) + MAXMP = MAX( M, P ) + MINMP = MIN( M, P ) + NM1 = N - 1 +C + IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN + INFO = -5 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. + $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN + INFO = -14 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01XD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( LJOBD ) THEN +C +C Replace D by D', if non-scalar. +C + DO 5 J = 1, MAXMP + IF ( J.LT.MINMP ) THEN + CALL DSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( P, D(1,J), 1, D(J,1), LDD ) + ELSE IF ( J.GT.M ) THEN + CALL DCOPY( M, D(J,1), LDD, D(1,J), 1 ) + END IF + 5 CONTINUE +C + END IF +C + IF( N.EQ.0 ) + $ RETURN +C +C Replace matrix A by P*A'*P. +C + IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN +C +C Full matrix A. +C + DO 10 J = 1, NM1 + CALL DSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) + 10 CONTINUE +C + ELSE +C +C Band matrix A. +C + LDA1 = LDA + 1 +C +C Pertranspose the KL subdiagonals. +C + DO 20 J = 1, MIN( KL, N-2 ) + J1 = ( N - J )/2 + CALL DSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) + 20 CONTINUE +C +C Pertranspose the KU superdiagonals. +C + DO 30 J = 1, MIN( KU, N-2 ) + J1 = ( N - J )/2 + CALL DSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) + 30 CONTINUE +C +C Pertranspose the diagonal. +C + J1 = N/2 + CALL DSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) +C + END IF +C +C Replace matrix B by P*C' and matrix C by B'*P. +C + DO 40 J = 1, MAXMP + IF ( J.LE.MINMP ) THEN + CALL DSWAP( N, B(1,J), 1, C(J,1), -LDC ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( N, B(1,J), 1, C(J,1), -LDC ) + ELSE + CALL DCOPY( N, C(J,1), -LDC, B(1,J), 1 ) + END IF + 40 CONTINUE +C + RETURN +C *** Last line of TB01XD *** + END diff --git a/mex/sources/libslicot/TB01XZ.f b/mex/sources/libslicot/TB01XZ.f new file mode 100644 index 000000000..ef73d0ce3 --- /dev/null +++ b/mex/sources/libslicot/TB01XZ.f @@ -0,0 +1,280 @@ + SUBROUTINE TB01XZ( JOBD, N, M, P, KL, KU, A, LDA, B, LDB, C, LDC, + $ D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a special transformation to a system given as a triple +C (A,B,C), +C +C A <-- P * A' * P, B <-- P * C', C <-- B' * P, +C +C where P is a matrix with 1 on the secondary diagonal, and with 0 +C in the other entries. Matrix A can be specified as a band matrix. +C Optionally, matrix D of the system can be transposed. This +C transformation is actually a special similarity transformation of +C the dual system. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state space model: +C = 'D': D is present; +C = 'Z': D is assumed a zero matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C KL (input) INTEGER +C The number of subdiagonals of A to be transformed. +C MAX( 0, N-1 ) >= KL >= 0. +C +C KU (input) INTEGER +C The number of superdiagonals of A to be transformed. +C MAX( 0, N-1 ) >= KU >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed (pertransposed) matrix P*A'*P. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B. +C On exit, the leading N-by-P part of this array contains +C the dual input/state matrix P*C'. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0 or P > 0. +C LDB >= 1 if M = 0 and P = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C. +C On exit, the leading M-by-N part of this array contains +C the dual state/output matrix B'*P. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C D (input/output) COMPLEX*16 array, dimension (LDD,MAX(M,P)) +C On entry, if JOBD = 'D', the leading P-by-M part of this +C array must contain the original direct transmission +C matrix D. +C On exit, if JOBD = 'D', the leading M-by-P part of this +C array contains the transposed direct transmission matrix +C D'. The array D is not referenced if JOBD = 'Z'. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,M,P) if JOBD = 'D'. +C LDD >= 1 if JOBD = 'Z'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The rows and/or columns of the matrices of the triplet (A,B,C) +C and, optionally, of the matrix D are swapped in a special way. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Matrix algebra, matrix operations, similarity transformation. +C +C ********************************************************************* +C +C .. +C .. Scalar Arguments .. + CHARACTER JOBD + INTEGER INFO, KL, KU, LDA, LDB, LDC, LDD, M, N, P +C .. +C .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ) +C .. +C .. Local Scalars .. + LOGICAL LJOBD + INTEGER J, J1, LDA1, MAXMP, MINMP, NM1 +C .. +C .. External functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. +C .. External Subroutines .. + EXTERNAL XERBLA, ZCOPY, ZSWAP +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 + LJOBD = LSAME( JOBD, 'D' ) + MAXMP = MAX( M, P ) + MINMP = MIN( M, P ) + NM1 = N - 1 +C + IF( .NOT.LJOBD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( KL.LT.0 .OR. KL.GT.MAX( 0, NM1 ) ) THEN + INFO = -5 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( 0, NM1 ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( ( MAXMP.GT.0 .AND. LDB.LT.MAX( 1, N ) ) .OR. + $ ( MINMP.EQ.0 .AND. LDB.LT.1 ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.1 .OR. ( LJOBD .AND. LDD.LT.MAXMP ) ) THEN + INFO = -14 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01XZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( LJOBD ) THEN +C +C Replace D by D', if non-scalar. +C + DO 5 J = 1, MAXMP + IF ( J.LT.MINMP ) THEN + CALL ZSWAP( MINMP-J, D(J+1,J), 1, D(J,J+1), LDD ) + ELSE IF ( J.GT.P ) THEN + CALL ZCOPY( P, D(1,J), 1, D(J,1), LDD ) + ELSE IF ( J.GT.M ) THEN + CALL ZCOPY( M, D(J,1), LDD, D(1,J), 1 ) + END IF + 5 CONTINUE +C + END IF +C + IF( N.EQ.0 ) + $ RETURN +C +C Replace matrix A by P*A'*P. +C + IF ( KL.EQ.NM1 .AND. KU.EQ.NM1 ) THEN +C +C Full matrix A. +C + DO 10 J = 1, NM1 + CALL ZSWAP( N-J, A( 1, J ), 1, A( N-J+1, J+1 ), -LDA ) + 10 CONTINUE +C + ELSE +C +C Band matrix A. +C + LDA1 = LDA + 1 +C +C Pertranspose the KL subdiagonals. +C + DO 20 J = 1, MIN( KL, N-2 ) + J1 = ( N - J )/2 + CALL ZSWAP( J1, A(J+1,1), LDA1, A(N-J1+1,N-J1+1-J), -LDA1 ) + 20 CONTINUE +C +C Pertranspose the KU superdiagonals. +C + DO 30 J = 1, MIN( KU, N-2 ) + J1 = ( N - J )/2 + CALL ZSWAP( J1, A(1,J+1), LDA1, A(N-J1+1-J,N-J1+1), -LDA1 ) + 30 CONTINUE +C +C Pertranspose the diagonal. +C + J1 = N/2 + CALL ZSWAP( J1, A(1,1), LDA1, A(N-J1+1,N-J1+1), -LDA1 ) +C + END IF +C +C Replace matrix B by P*C' and matrix C by B'*P. +C + DO 40 J = 1, MAXMP + IF ( J.LE.MINMP ) THEN + CALL ZSWAP( N, B(1,J), 1, C(J,1), -LDC ) + ELSE IF ( J.GT.P ) THEN + CALL ZCOPY( N, B(1,J), 1, C(J,1), -LDC ) + ELSE + CALL ZCOPY( N, C(J,1), -LDC, B(1,J), 1 ) + END IF + 40 CONTINUE +C + RETURN +C *** Last line of TB01XZ *** + END diff --git a/mex/sources/libslicot/TB01YD.f b/mex/sources/libslicot/TB01YD.f new file mode 100644 index 000000000..f653ffab5 --- /dev/null +++ b/mex/sources/libslicot/TB01YD.f @@ -0,0 +1,188 @@ + SUBROUTINE TB01YD( N, M, P, A, LDA, B, LDB, C, LDC, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To apply a special similarity transformation to a system given as +C a triple (A,B,C), +C +C A <-- P * A * P, B <-- P * B, C <-- C * P, +C +C where P is a matrix with 1 on the secondary diagonal, and with 0 +C in the other entries. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A, the number of rows of matrix B +C and the number of columns of matrix C. +C N represents the dimension of the state vector. N >= 0. +C +C M (input) INTEGER. +C The number of columns of matrix B. +C M represents the dimension of input vector. M >= 0. +C +C P (input) INTEGER. +C The number of rows of matrix C. +C P represents the dimension of output vector. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the system state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed matrix P*A*P. +C +C LDA INTEGER +C The leading dimension of the array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the system input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed matrix P*B. +C +C LDB INTEGER +C The leading dimension of the array B. +C LDB >= MAX(1,N) if M > 0. +C LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the system output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*P. +C +C LDC INTEGER +C The leading dimension of the array C. LDC >= MAX(1,P). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The rows and/or columns of the matrices of the triplet (A,B,C) +C are swapped in a special way. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004. +C +C KEYWORDS +C +C Matrix algebra, matrix operations, similarity transformation. +C +C ********************************************************************* +C +C .. +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, M, N, P +C .. +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +C .. +C .. Local Scalars .. + INTEGER J, NBY2 +C .. +C .. External Subroutines .. + EXTERNAL DSWAP, XERBLA +C .. +C .. Intrinsic Functions .. + INTRINSIC MAX, MOD +C .. +C .. Executable Statements .. +C +C Test the scalar input arguments. +C + INFO = 0 +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -9 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01YD', -INFO ) + RETURN + END IF +C + IF( N.LE.1 ) + $ RETURN +C +C Transform the matrix A. +C + NBY2 = N/2 +C + DO 10 J = 1, NBY2 + CALL DSWAP( N, A( 1, J ), -1, A( 1, N-J+1 ), 1 ) + 10 CONTINUE +C + IF( MOD( N, 2 ).NE.0 .AND. N.GT.2 ) + $ CALL DSWAP( NBY2, A( NBY2+2, NBY2+1 ), -1, A( 1, NBY2+1 ), 1 ) +C + IF( M.GT.0 ) THEN +C +C Transform the matrix B. +C + DO 20 J = 1, NBY2 + CALL DSWAP( M, B( J, 1 ), LDB, B( N-J+1, 1 ), LDB ) + 20 CONTINUE +C + END IF +C + IF( P.GT.0 ) THEN +C +C Transform the matrix C. +C + DO 30 J = 1, NBY2 + CALL DSWAP( P, C( 1, J ), 1, C( 1, N-J+1 ), 1 ) + 30 CONTINUE +C + END IF +C + RETURN +C *** Last line of TB01YD *** + END diff --git a/mex/sources/libslicot/TB01ZD.f b/mex/sources/libslicot/TB01ZD.f new file mode 100644 index 000000000..6f8acc3a4 --- /dev/null +++ b/mex/sources/libslicot/TB01ZD.f @@ -0,0 +1,440 @@ + SUBROUTINE TB01ZD( JOBZ, N, P, A, LDA, B, C, LDC, NCONT, Z, LDZ, + $ TAU, TOL, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a controllable realization for the linear time-invariant +C single-input system +C +C dX/dt = A * X + B * U, +C Y = C * X, +C +C where A is an N-by-N matrix, B is an N element vector, C is an +C P-by-N matrix, and A and B are reduced by this routine to +C orthogonal canonical form using (and optionally accumulating) +C orthogonal similarity transformations, which are also applied +C to C. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBZ CHARACTER*1 +C Indicates whether the user wishes to accumulate in a +C matrix Z the orthogonal similarity transformations for +C reducing the system, as follows: +C = 'N': Do not form Z and do not store the orthogonal +C transformations; +C = 'F': Do not form Z, but store the orthogonal +C transformations in the factored form; +C = 'I': Z is initialized to the unit matrix and the +C orthogonal transformation matrix Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e. the order of the matrix A. N >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NCONT-by-NCONT upper Hessenberg +C part of this array contains the canonical form of the +C state dynamics matrix, given by Z' * A * Z, of a +C controllable realization for the original system. The +C elements below the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, the original input/state vector B. +C On exit, the leading NCONT elements of this array contain +C canonical form of the input/state vector, given by Z' * B, +C with all elements but B(1) set to zero. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output/state matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output/state matrix, given by C * Z, and +C the leading P-by-NCONT part contains the output/state +C matrix of the controllable realization. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C NCONT (output) INTEGER +C The order of the controllable state-space representation. +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C If JOBZ = 'I', then the leading N-by-N part of this array +C contains the matrix of accumulated orthogonal similarity +C transformations which reduces the given system to +C orthogonal canonical form. +C If JOBZ = 'F', the elements below the diagonal, with the +C array TAU, represent the orthogonal transformation matrix +C as a product of elementary reflectors. The transformation +C matrix can then be obtained by calling the LAPACK Library +C routine DORGQR. +C If JOBZ = 'N', the array Z is not referenced and can be +C supplied as a dummy array (i.e. set parameter LDZ = 1 and +C declare this array to be Z(1,1) in the calling program). +C +C LDZ INTEGER +C The leading dimension of array Z. If JOBZ = 'I' or +C JOBZ = 'F', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1. +C +C TAU (output) DOUBLE PRECISION array, dimension (N) +C The elements of TAU contain the scalar factors of the +C elementary reflectors used in the reduction of B and A. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the +C controllability of (A,B). If the user sets TOL > 0, then +C the given value of TOL is used as an absolute tolerance; +C elements with absolute value less than TOL are considered +C neglijible. If the user sets TOL <= 0, then an implicitly +C computed, default tolerance, defined by +C TOLDEF = N*EPS*MAX( NORM(A), NORM(B) ) is used instead, +C where EPS is the machine precision (see LAPACK Library +C routine DLAMCH). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= MAX(1,N,P). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The Householder matrix which reduces all but the first element +C of vector B to zero is found and this orthogonal similarity +C transformation is applied to the matrix A. The resulting A is then +C reduced to upper Hessenberg form by a sequence of Householder +C transformations. Finally, the order of the controllable state- +C space representation (NCONT) is determined by finding the position +C of the first sub-diagonal element of A which is below an +C appropriate zero threshold, either TOL or TOLDEF (see parameter +C TOL); if NORM(B) is smaller than this threshold, NCONT is set to +C zero, and no computations for reducing the system to orthogonal +C canonical form are performed. +C All orthogonal transformations determined in this process are also +C applied to the matrix C, from the right. +C +C REFERENCES +C +C [1] Konstantinov, M.M., Petkov, P.Hr. and Christov, N.D. +C Orthogonal Invariants and Canonical Forms for Linear +C Controllable Systems. +C Proc. 8th IFAC World Congress, Kyoto, 1, pp. 49-54, 1981. +C +C [2] Hammarling, S.J. +C Notes on the use of orthogonal similarity transformations in +C control. +C NPL Report DITC 8/82, August 1982. +C +C [3] Paige, C.C +C Properties of numerical algorithms related to computing +C controllability. +C IEEE Trans. Auto. Contr., AC-26, pp. 130-138, 1981. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations and is backward stable. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1998. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Oct. 2001, +C Sept. 2003. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBZ + INTEGER INFO, LDA, LDC, LDWORK, LDZ, N, NCONT, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), C(LDC,*), DWORK(*), TAU(*), + $ Z(LDZ,*) +C .. Local Scalars .. + LOGICAL LJOBF, LJOBI, LJOBZ + INTEGER ITAU, J + DOUBLE PRECISION ANORM, B1, BNORM, FANORM, FBNORM, H, THRESH, + $ TOLDEF, WRKOPT +C .. Local Arrays .. + DOUBLE PRECISION NBLK(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DGEHRD, DLACPY, DLARF, DLARFG, DLASET, DORGQR, + $ DORMHR, MB01PD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX +C .. Executable Statements .. +C + INFO = 0 + LJOBF = LSAME( JOBZ, 'F' ) + LJOBI = LSAME( JOBZ, 'I' ) + LJOBZ = LJOBF.OR.LJOBI +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDZ.LT.1 .OR. ( LJOBZ .AND. LDZ.LT.N ) ) THEN + INFO = -11 + ELSE IF( LDWORK.LT.MAX( 1, N, P ) ) THEN + INFO = -15 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB01ZD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + NCONT = 0 + DWORK(1) = ONE + IF ( N.EQ.0 ) + $ RETURN +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = ONE +C +C Calculate the absolute norms of A and B (used for scaling). +C + ANORM = DLANGE( 'Max', N, N, A, LDA, DWORK ) + BNORM = DLANGE( 'Max', N, 1, B, N, DWORK ) +C +C Return if matrix B is zero. +C + IF( BNORM.EQ.ZERO ) THEN + IF( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + ELSE IF( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + END IF + RETURN + END IF +C +C Scale (if needed) the matrices A and B. +C + CALL MB01PD( 'S', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, INFO ) + CALL MB01PD( 'S', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) +C +C Calculate the Frobenius norm of A and the 1-norm of B (used for +C controlability test). +C + FANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + FBNORM = DLANGE( '1-norm', N, 1, B, N, DWORK ) +C + TOLDEF = TOL + IF ( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + THRESH = DBLE(N)*DLAMCH( 'EPSILON' ) + TOLDEF = THRESH*MAX( FANORM, FBNORM ) + END IF +C + ITAU = 1 + IF ( FBNORM.GT.TOLDEF ) THEN +C +C B is not negligible compared with A. +C + IF ( N.GT.1 ) THEN +C +C Transform B by a Householder matrix Z1: store vector +C describing this temporarily in B and in the local scalar H. +C + CALL DLARFG( N, B(1), B(2), 1, H ) +C + B1 = B(1) + B(1) = ONE +C +C Form Z1 * A * Z1. +C Workspace: need N. +C + CALL DLARF( 'Right', N, N, B, 1, H, A, LDA, DWORK ) + CALL DLARF( 'Left', N, N, B, 1, H, A, LDA, DWORK ) +C +C Form C * Z1. +C Workspace: need P. +C + CALL DLARF( 'Right', P, N, B, 1, H, C, LDC, DWORK ) +C + B(1) = B1 + TAU(1) = H + ITAU = ITAU + 1 + ELSE + B1 = B(1) + TAU(1) = ZERO + END IF +C +C Reduce modified A to upper Hessenberg form by an orthogonal +C similarity transformation with matrix Z2. +C Workspace: need N; prefer N*NB. +C + CALL DGEHRD( N, 1, N, A, LDA, TAU(ITAU), DWORK, LDWORK, INFO ) + WRKOPT = DWORK(1) +C +C Form C * Z2. +C Workspace: need P; prefer P*NB. +C + CALL DORMHR( 'Right', 'No transpose', P, N, 1, N, A, LDA, + $ TAU(ITAU), C, LDC, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) +C + IF ( LJOBZ ) THEN +C +C Save the orthogonal transformations used, so that they could +C be accumulated by calling DORGQR routine. +C + IF ( N.GT.1 ) + $ CALL DLACPY( 'Full', N-1, 1, B(2), N-1, Z(2,1), LDZ ) + IF ( N.GT.2 ) + $ CALL DLACPY( 'Lower', N-2, N-2, A(3,1), LDA, Z(3,2), + $ LDZ ) + IF ( LJOBI ) THEN +C +C Form the orthogonal transformation matrix Z = Z1 * Z2. +C Workspace: need N; prefer N*NB. +C + CALL DORGQR( N, N, N, Z, LDZ, TAU, DWORK, LDWORK, INFO ) + WRKOPT = MAX( WRKOPT, DWORK(1) ) + END IF + END IF +C +C Annihilate the lower part of A and B. +C + IF ( N.GT.2 ) + $ CALL DLASET( 'Lower', N-2, N-2, ZERO, ZERO, A(3,1), LDA ) + IF ( N.GT.1 ) + $ CALL DLASET( 'Full', N-1, 1, ZERO, ZERO, B(2), N-1 ) +C +C Find NCONT by checking sizes of the sub-diagonal elements of +C transformed A. +C + IF ( TOL.LE.ZERO ) + $ TOLDEF = THRESH*MAX( FANORM, ABS( B1 ) ) +C + J = 1 +C +C WHILE ( J < N and ABS( A(J+1,J) ) > TOLDEF ) DO +C + 10 CONTINUE + IF ( J.LT.N ) THEN + IF ( ABS( A(J+1,J) ).GT.TOLDEF ) THEN + J = J + 1 + GO TO 10 + END IF + END IF +C +C END WHILE 10 +C +C First negligible sub-diagonal element found, if any: set NCONT. +C + NCONT = J + IF ( J.LT.N ) + $ A(J+1,J) = ZERO +C +C Undo scaling of A and B. +C + CALL MB01PD( 'U', 'H', NCONT, NCONT, 0, 0, ANORM, 0, NBLK, A, + $ LDA, INFO ) + CALL MB01PD( 'U', 'G', 1, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) + IF ( NCONT.LT.N ) + $ CALL MB01PD( 'U', 'G', N, N-NCONT, 0, 0, ANORM, 0, NBLK, + $ A(1,NCONT+1), LDA, INFO ) + ELSE +C +C B is negligible compared with A. No computations for reducing +C the system to orthogonal canonical form have been performed, +C except scaling (which is undoed). +C + CALL MB01PD( 'U', 'G', N, N, 0, 0, ANORM, 0, NBLK, A, LDA, + $ INFO ) + CALL MB01PD( 'U', 'G', N, 1, 0, 0, BNORM, 0, NBLK, B, N, INFO ) + IF( LJOBF ) THEN + CALL DLASET( 'Full', N, N, ZERO, ZERO, Z, LDZ ) + CALL DLASET( 'Full', N, 1, ZERO, ZERO, TAU, N ) + ELSE IF( LJOBI ) THEN + CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + END IF + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TB01ZD *** + END diff --git a/mex/sources/libslicot/TB03AD.f b/mex/sources/libslicot/TB03AD.f new file mode 100644 index 000000000..318c2f323 --- /dev/null +++ b/mex/sources/libslicot/TB03AD.f @@ -0,0 +1,746 @@ + SUBROUTINE TB03AD( LERI, EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, + $ D, LDD, NR, INDEX, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a relatively prime left polynomial matrix representation +C inv(P(s))*Q(s) or right polynomial matrix representation +C Q(s)*inv(P(s)) with the same transfer matrix T(s) as that of a +C given state-space representation, i.e. +C +C inv(P(s))*Q(s) = Q(s)*inv(P(s)) = T(s) = C*inv(s*I-A)*B + D. +C +C ARGUMENTS +C +C Mode Parameters +C +C LERI CHARACTER*1 +C Indicates whether the left polynomial matrix +C representation or the right polynomial matrix +C representation is required as follows: +C = 'L': A left matrix fraction is required; +C = 'R': A right matrix fraction is required. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the triplet +C (A,B,C), before computing a minimal state-space +C representation, as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the original state dynamics matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NR-by-NR part of this array contains +C the upper block Hessenberg state dynamics matrix Amin of a +C minimal realization for the original system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B; the remainder +C of the leading N-by-MAX(M,P) part is used as internal +C workspace. +C On exit, the leading NR-by-M part of this array contains +C the transformed input/state matrix Bmin. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C; the remainder +C of the leading MAX(M,P)-by-N part is used as internal +C workspace. +C On exit, the leading P-by-NR part of this array contains +C the transformed state/output matrix Cmin. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) +C The leading P-by-M part of this array must contain the +C original direct transmission matrix D; the remainder of +C the leading MAX(M,P)-by-MAX(M,P) part is used as internal +C workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C NR (output) INTEGER +C The order of the minimal state-space representation +C (Amin,Bmin,Cmin). +C +C INDEX (output) INTEGER array, dimension (P), if LERI = 'L', or +C dimension (M), if LERI = 'R'. +C If LERI = 'L', INDEX(I), I = 1,2,...,P, contains the +C maximum degree of the polynomials in the I-th row of the +C denominator matrix P(s) of the left polynomial matrix +C representation. +C These elements are ordered so that +C INDEX(1) >= INDEX(2) >= ... >= INDEX(P). +C If LERI = 'R', INDEX(I), I = 1,2,...,M, contains the +C maximum degree of the polynomials in the I-th column of +C the denominator matrix P(s) of the right polynomial +C matrix representation. +C These elements are ordered so that +C INDEX(1) >= INDEX(2) >= ... >= INDEX(M). +C +C PCOEFF (output) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,N+1) +C If LERI = 'L' then porm = P, otherwise porm = M. +C The leading porm-by-porm-by-kpcoef part of this array +C contains the coefficients of the denominator matrix P(s), +C where kpcoef = MAX(INDEX(I)) + 1. +C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if +C LERI = 'L' then iorj = I, otherwise iorj = J. +C Thus for LERI = 'L', P(s) = +C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P), if LERI = 'L'; +C LDPCO1 >= MAX(1,M), if LERI = 'R'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P), if LERI = 'L'; +C LDPCO2 >= MAX(1,M), if LERI = 'R'. +C +C QCOEFF (output) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,N+1) +C If LERI = 'L' then porp = M, otherwise porp = P. +C If LERI = 'L', the leading porm-by-porp-by-kpcoef part +C of this array contains the coefficients of the numerator +C matrix Q(s). +C If LERI = 'R', the leading porp-by-porm-by-kpcoef part +C of this array contains the coefficients of the numerator +C matrix Q(s). +C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C LDQCO1 >= MAX(1,P), if LERI = 'L'; +C LDQCO1 >= MAX(1,M,P), if LERI = 'R'. +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C LDQCO2 >= MAX(1,M), if LERI = 'L'; +C LDQCO2 >= MAX(1,M,P), if LERI = 'R'. +C +C VCOEFF (output) DOUBLE PRECISION array, dimension +C (LDVCO1,LDVCO2,N+1) +C The leading porm-by-NR-by-kpcoef part of this array +C contains the coefficients of the intermediate matrix V(s). +C VCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C +C LDVCO1 INTEGER +C The leading dimension of array VCOEFF. +C LDVCO1 >= MAX(1,P), if LERI = 'L'; +C LDVCO1 >= MAX(1,M), if LERI = 'R'. +C +C LDVCO2 INTEGER +C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B, C). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance +C (determined by the SLICOT routine TB01UD) is used instead. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) +C where PM = P, if LERI = 'L'; +C PM = M, if LERI = 'R'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if a singular matrix was encountered during the +C computation of V(s); +C = 2: if a singular matrix was encountered during the +C computation of P(s). +C +C METHOD +C +C The method for a left matrix fraction will be described here: +C right matrix fractions are dealt with by constructing a left +C fraction for the dual of the original system. The first step is to +C obtain, by means of orthogonal similarity transformations, a +C minimal state-space representation (Amin,Bmin,Cmin,D) for the +C original system (A,B,C,D), where Amin is lower block Hessenberg +C with all its superdiagonal blocks upper triangular and Cmin has +C all but its first rank(C) columns zero. The number and dimensions +C of the blocks of Amin now immediately yield the row degrees of +C P(s) with P(s) row proper: furthermore, the P-by-NR polynomial +C matrix V(s) (playing a similar role to S(s) in Wolovich's +C Structure Theorem) can be calculated a column block at a time, in +C reverse order, from Amin. P(s) is then found as if it were the +C O-th column block of V(s) (using Cmin as well as Amin), while +C Q(s) = (V(s) * Bmin) + (P(s) * D). Finally, a special similarity +C transformation is used to put Amin in an upper block Hessenberg +C form. +C +C REFERENCES +C +C [1] Williams, T.W.C. +C An Orthogonal Structure Theorem for Linear Systems. +C Kingston Polytechnic Control Systems Research Group, +C Internal Report 82/2, July 1982. +C +C [2] Patel, R.V. +C On Computing Matrix Fraction Descriptions and Canonical +C Forms of Linear Time-Invariant Systems. +C UMIST Control Systems Centre Report 489, 1980. +C (Algorithms 1 and 2, extensively modified). +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. +C Supersedes Release 3.0 routine TB01SD. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000. +C +C KEYWORDS +C +C Canonical form, coprime matrix fraction, dual system, elementary +C polynomial operations, Hessenberg form, minimal realization, +C orthogonal transformation, polynomial matrix, state-space +C representation, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, LERI + INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, + $ LDQCO1, LDQCO2, LDVCO1, LDVCO2, LDWORK, M, N, + $ NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), + $ QCOEFF(LDQCO1,LDQCO2,*), VCOEFF(LDVCO1,LDVCO2,*) +C .. Local Scalars .. + LOGICAL LEQUIL, LLERIL, LLERIR + INTEGER I, IC, IFIRST, INDBLK, INPLUS, IOFF, IRANKC, + $ ISTART, ISTOP, ITAU, IZ, JOFF, JWORK, K, KMAX, + $ KPCOEF, KPLUS, KWORK, LDWRIC, MAXMP, MPLIM, + $ MWORK, NCOL, NCONT, NREFLC, NROW, PWORK, WRKOPT + DOUBLE PRECISION MAXRED +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, DGEMM, DGEQRF, DGETRF, DLACPY, DLASET, + $ DORMQR, DTRSM, MA02GD, TB01ID, TB01UD, TB01YD, + $ TB03AY, TC01OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + LLERIL = LSAME( LERI, 'L' ) + LLERIR = LSAME( LERI, 'R' ) + LEQUIL = LSAME( EQUIL, 'S' ) + MAXMP = MAX( M, P ) + MPLIM = MAX( 1, MAXMP ) + IF ( LLERIR ) THEN +C +C Initialization for right matrix fraction. +C + PWORK = M + MWORK = P + ELSE +C +C Initialization for left matrix fraction. +C + PWORK = P + MWORK = M + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.LLERIL .AND. .NOT.LLERIR ) THEN + INFO = -1 + ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MPLIM ) THEN + INFO = -11 + ELSE IF( LDD.LT.MPLIM ) THEN + INFO = -13 + ELSE IF( LDPCO1.LT.MAX( 1, PWORK ) ) THEN + INFO = -17 + ELSE IF( LDPCO2.LT.MAX( 1, PWORK ) ) THEN + INFO = -18 + ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. LLERIR .AND. + $ LDQCO1.LT.MPLIM ) THEN + INFO = -20 + ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. LLERIR .AND. + $ LDQCO2.LT.MPLIM ) THEN + INFO = -21 + ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN + INFO = -23 + ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN + INFO = -24 + ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), + $ PWORK*( PWORK + 2 ) ) ) THEN + INFO = -28 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB03AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF ( LLERIR ) THEN +C +C For right matrix fraction, obtain dual system. +C + CALL AB07MD( 'D', N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) + END IF +C +C Obtain minimal realization, in canonical form, for this system. +C Part of the code in SLICOT routine TB01PD is included in-line +C here. (TB01PD cannot be directly used.) +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C If required, balance the triplet (A,B,C) (default MAXRED). +C Workspace: need N. +C + IF ( LEQUIL ) THEN + MAXRED = ZERO + CALL TB01ID( 'A', N, MWORK, PWORK, MAXRED, A, LDA, B, LDB, C, + $ LDC, DWORK, INFO ) + END IF +C + IZ = 1 + ITAU = 1 + JWORK = ITAU + N +C +C Separate out controllable subsystem (of order NCONT): +C A <-- Z'*A*Z, B <-- Z'*B, C <-- C*Z. +C +C Workspace: need N + MAX(N, 3*MWORK, PWORK). +C prefer larger. +C + CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, + $ NCONT, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, + $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 +C +C Separate out the observable subsystem (of order NR): +C Form the dual of the subsystem of order NCONT (which is +C controllable), leaving rest as it is. +C + CALL AB07MD( 'Z', NCONT, MWORK, PWORK, A, LDA, B, LDB, C, LDC, + $ DWORK, 1, INFO ) +C +C And separate out the controllable part of this dual subsystem. +C +C Workspace: need NCONT + MAX(NCONT, 3*PWORK, MWORK). +C prefer larger. +C + CALL TB01UD( 'No Z', NCONT, PWORK, MWORK, A, LDA, B, LDB, C, LDC, + $ NR, INDBLK, IWORK, DWORK(IZ), 1, DWORK(ITAU), TOL, + $ IWORK(N+1), DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Retranspose, giving controllable and observable (i.e. minimal) +C part of original system. +C + CALL AB07MD( 'Z', NR, PWORK, MWORK, A, LDA, B, LDB, C, LDC, DWORK, + $ 1, INFO ) +C +C Annihilate the trailing components of IWORK(1:N). +C + DO 10 I = INDBLK + 1, N + IWORK(I) = 0 + 10 CONTINUE +C +C Initialize polynomial matrices P(s), Q(s) and V(s) to zero. +C + DO 20 K = 1, N + 1 + CALL DLASET( 'Full', PWORK, PWORK, ZERO, ZERO, PCOEFF(1,1,K), + $ LDPCO1 ) + CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, QCOEFF(1,1,K), + $ LDQCO1 ) + CALL DLASET( 'Full', PWORK, NR, ZERO, ZERO, VCOEFF(1,1,K), + $ LDVCO1 ) + 20 CONTINUE +C +C Finish initializing V(s), and set up row degrees of P(s). +C + INPLUS = INDBLK + 1 + ISTART = 1 + JOFF = NR +C + DO 40 K = 1, INDBLK + KWORK = INPLUS - K + KPLUS = KWORK + 1 + ISTOP = IWORK(KWORK) + JOFF = JOFF - ISTOP +C + DO 30 I = ISTART, ISTOP + INDEX(I) = KWORK + VCOEFF(I,JOFF+I,KPLUS) = ONE + 30 CONTINUE +C + ISTART = ISTOP + 1 + 40 CONTINUE +C +C ISTART = IWORK(1)+1 now: if .LE. PWORK, set up final rows of P(s). +C + DO 50 I = ISTART, PWORK + INDEX(I) = 0 + PCOEFF(I,I,1) = ONE + 50 CONTINUE +C +C Triangularize the superdiagonal blocks of Amin. +C + NROW = IWORK(INDBLK) + IOFF = NR - NROW + KMAX = INDBLK - 1 + ITAU = 1 + IFIRST = 0 + IF ( INDBLK.GT.2 ) IFIRST = IOFF - IWORK(KMAX) +C +C QR decomposition of each superdiagonal block of A in turn +C (done in reverse order to preserve upper triangular blocks in A). +C + DO 60 K = 1, KMAX +C +C Calculate dimensions of new block & its position in A. +C + KWORK = INDBLK - K + NCOL = NROW + NROW = IWORK(KWORK) + JOFF = IOFF + IOFF = IOFF - NROW + NREFLC = MIN( NROW, NCOL ) + JWORK = ITAU + NREFLC + IF ( KWORK.GE.2 ) IFIRST = IFIRST - IWORK(KWORK-1) +C +C Find QR decomposition of this (full rank) block: +C block = QR. No pivoting is needed. +C +C Workspace: need MIN(NROW,NCOL) + NCOL; +C prefer MIN(NROW,NCOL) + NCOL*NB. +C + CALL DGEQRF( NROW, NCOL, A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Premultiply appropriate row block of A by Q'. +C +C Workspace: need MIN(NROW,NCOL) + JOFF; +C prefer MIN(NROW,NCOL) + JOFF*NB. +C + CALL DORMQR( 'Left', 'Transpose', NROW, JOFF, NREFLC, + $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), A(IOFF+1,1), + $ LDA, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Premultiply appropriate row block of B by Q' also. +C +C Workspace: need MIN(NROW,NCOL) + MWORK; +C prefer MIN(NROW,NCOL) + MWORK*NB. +C + CALL DORMQR( 'Left', 'Transpose', NROW, MWORK, NREFLC, + $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), B(IOFF+1,1), + $ LDB, DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C And postmultiply the non-zero part of appropriate column +C block of A by Q. +C +C Workspace: need MIN(NROW,NCOL) + NR; +C prefer MIN(NROW,NCOL) + NR*NB. +C + CALL DORMQR( 'Right', 'No Transpose', NR-IFIRST, NROW, NREFLC, + $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), + $ A(IFIRST+1,IOFF+1), LDA, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Annihilate the lower triangular part of the block in A. +C + IF ( K.NE.KMAX .AND. NROW.GT.1 ) + $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, + $ A(IOFF+2,JOFF+1), LDA ) +C + 60 CONTINUE +C +C Finally: postmultiply non-zero columns of C by Q (K = KMAX). +C +C Workspace: need MIN(NROW,NCOL) + PWORK; +C prefer MIN(NROW,NCOL) + PWORK*NB. +C + CALL DORMQR( 'Right', 'No Transpose', PWORK, NROW, NREFLC, + $ A(IOFF+1,JOFF+1), LDA, DWORK(ITAU), C, LDC, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Annihilate the lower triangular part of the block in A. +C + IF ( NROW.GT.1 ) + $ CALL DLASET( 'Lower', NROW-1, NCOL, ZERO, ZERO, + $ A(IOFF+2,JOFF+1), LDA ) +C +C Calculate the (PWORK x NR) polynomial matrix V(s) ... +C + CALL TB03AY( NR, A, LDA, INDBLK, IWORK, VCOEFF, LDVCO1, LDVCO2, + $ PCOEFF, LDPCO1, LDPCO2, INFO) +C + IF ( INFO.NE.0 ) THEN + INFO = 1 + RETURN + ELSE +C +C And then use this matrix to calculate P(s): first store +C C1 from C. +C + IC = 1 + IRANKC = IWORK(1) + LDWRIC = MAX( 1, PWORK ) + CALL DLACPY( 'Full', PWORK, IRANKC, C, LDC, DWORK(IC), LDWRIC ) +C + IF ( IRANKC.LT.PWORK ) THEN +C +C rank(C) .LT. PWORK: obtain QR decomposition of C1, +C giving R and Q. +C +C Workspace: need PWORK*IRANKC + 2*IRANKC; +C prefer PWORK*IRANKC + IRANKC + IRANKC*NB. +C + ITAU = IC + LDWRIC*IRANKC + JWORK = ITAU + IRANKC +C + CALL DGEQRF( PWORK, IRANKC, DWORK(IC), LDWRIC, DWORK(ITAU), + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C First IRANKC rows of Pbar(s) are given by Wbar(s) * inv(R). +C Check for zero diagonal elements of R. +C + DO 70 I = 1, IRANKC + IF ( DWORK(IC+(I-1)*LDWRIC+I-1).EQ.ZERO ) THEN +C +C Error return. +C + INFO = 2 + RETURN + END IF + 70 CONTINUE +C + NROW = IRANKC +C + DO 80 K = 1, INPLUS + CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', + $ NROW, IRANKC, ONE, DWORK(IC), LDWRIC, + $ PCOEFF(1,1,K), LDPCO1 ) + NROW = IWORK(K) + 80 CONTINUE +C +C P(s) itself is now given by Pbar(s) * Q'. +C + NROW = PWORK +C + DO 90 K = 1, INPLUS +C +C Workspace: need PWORK*IRANKC + IRANKC + NROW; +C prefer PWORK*IRANKC + IRANKC + NROW*NB. +C + CALL DORMQR( 'Right', 'Transpose', NROW, PWORK, IRANKC, + $ DWORK(IC), LDWRIC, DWORK(ITAU), + $ PCOEFF(1,1,K), LDPCO1, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + NROW = IWORK(K) + 90 CONTINUE +C + ELSE +C +C Special case rank(C) = PWORK, full: +C no QR decomposition (P(s)=Wbar(s)*inv(C1)). +C + CALL DGETRF( PWORK, PWORK, DWORK(IC), LDWRIC, IWORK(N+1), + $ INFO ) +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + INFO = 2 + RETURN + ELSE +C + NROW = IRANKC +C +C Workspace: need PWORK*IRANKC + N. +C + DO 100 K = 1, INPLUS + CALL DTRSM( 'Right', 'Upper', 'No Transpose', + $ 'Non-unit', NROW, PWORK, ONE, DWORK(IC), + $ LDWRIC, PCOEFF(1,1,K), LDPCO1 ) + CALL DTRSM( 'Right', 'Lower', 'No Transpose', 'Unit', + $ NROW, PWORK, ONE, DWORK(IC), LDWRIC, + $ PCOEFF(1,1,K), LDPCO1 ) + CALL MA02GD( NROW, PCOEFF(1,1,K), LDPCO1, 1, PWORK, + $ IWORK(N+1), -1 ) + NROW = IWORK(K) + 100 CONTINUE + END IF + END IF +C +C Finally, Q(s) = V(s) * B + P(s) * D can now be evaluated. +C + NROW = PWORK +C + DO 110 K = 1, INPLUS + CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, + $ NR, ONE, VCOEFF(1,1,K), LDVCO1, B, LDB, ZERO, + $ QCOEFF(1,1,K), LDQCO1 ) + CALL DGEMM( 'No transpose', 'No transpose', NROW, MWORK, + $ PWORK, ONE, PCOEFF(1,1,K), LDPCO1, D, LDD, ONE, + $ QCOEFF(1,1,K), LDQCO1 ) + NROW = IWORK(K) + 110 CONTINUE +C + END IF +C + IF ( LLERIR ) THEN +C +C For right matrix fraction, return to original (dual of dual) +C system. +C + CALL AB07MD( 'Z', NR, MWORK, PWORK, A, LDA, B, LDB, C, LDC, + $ DWORK, 1, INFO ) +C +C Also, obtain the dual of the polynomial matrix representation. +C + KPCOEF = 0 +C + DO 120 I = 1, PWORK + KPCOEF = MAX( KPCOEF, INDEX(I) ) + 120 CONTINUE +C + KPCOEF = KPCOEF + 1 + CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) + ELSE +C +C Reorder the rows and columns of the system, to get an upper +C block Hessenberg matrix A of the minimal system. +C + CALL TB01YD( NR, M, P, A, LDA, B, LDB, C, LDC, INFO ) + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT + RETURN +C *** Last line of TB03AD *** + END diff --git a/mex/sources/libslicot/TB03AY.f b/mex/sources/libslicot/TB03AY.f new file mode 100644 index 000000000..eeffc6e23 --- /dev/null +++ b/mex/sources/libslicot/TB03AY.f @@ -0,0 +1,159 @@ + SUBROUTINE TB03AY( NR, A, LDA, INDBLK, NBLK, VCOEFF, LDVCO1, + $ LDVCO2, PCOEFF, LDPCO1, LDPCO2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To calculate the (PWORK-by-NR) polynomial matrix V(s) one +C (PWORK-by-NBLK(L-1)) block V:L-1(s) at a time, in reverse order +C (L = INDBLK,...,1). At each stage, the (NBLK(L)-by-NBLK(L)) poly- +C nomial matrix W(s) = V2(s) * A2 is formed, where V2(s) is that +C part of V(s) already computed and A2 is the subdiagonal (incl.) +C part of the L-th column block of A; W(s) is temporarily stored in +C the top left part of P(s), as is subsequently the further matrix +C Wbar(s) = s * V:L(s) - W(s). Then, except for the final stage +C L = 1 (when the next step is to calculate P(s) itself, not here), +C the top left part of V:L-1(s) is given by Wbar(s) * inv(R), where +C R is the upper triangular part of the L-th superdiagonal block of +C A. Finally, note that the coefficient matrices W(.,.,K) can only +C be non-zero for K = L + 1,...,INPLUS, with each of these matrices +C having only its first NBLK(L-1) rows non-trivial. Similarly, +C Wbar(.,.,K) (and so clearly V:L-1(.,.,K) ) can only be non-zero +C for K = L,...,INPLUS, with each of these having only its first +C NBLK(K-1) rows non-trivial except for K = L, which has NBLK(L) +C such rows. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C NOTE: In the interests of speed, this routine does not check the +C inputs for errors. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INDBLK, INFO, LDA, LDPCO1, LDPCO2, LDVCO1, + $ LDVCO2, NR +C .. Array Arguments .. + INTEGER NBLK(*) + DOUBLE PRECISION A(LDA,*), PCOEFF(LDPCO1,LDPCO2,*), + $ VCOEFF(LDVCO1,LDVCO2,*) +C .. Local Scalars .. + INTEGER I, INPLUS, IOFF, J, JOFF, K, KPLUS, L, LSTART, + $ LSTOP, LWORK, NCOL, NROW +C .. External Subroutines .. + EXTERNAL DAXPY, DGEMM, DLACPY, DSCAL, DTRSM +C .. Executable Statements .. +C + INFO = 0 + INPLUS = INDBLK + 1 + JOFF = NR +C +C Calculate each column block V:LWORK-1(s) of V(s) in turn. +C + DO 70 L = 1, INDBLK + LWORK = INPLUS - L +C +C Determine number of columns of V:LWORK(s) & its position in V. +C + NCOL = NBLK(LWORK) + JOFF = JOFF - NCOL +C +C Find limits for V2(s) * A2 calculation: skips zero rows +C in V(s). +C + LSTART = JOFF + 1 + LSTOP = JOFF +C +C Calculate W(s) and store (temporarily) in top left part +C of P(s). +C + DO 10 K = LWORK + 1, INPLUS + NROW = NBLK(K-1) + LSTOP = LSTOP + NROW + CALL DGEMM( 'No transpose', 'No transpose', NROW, NCOL, + $ LSTOP-LSTART+1, ONE, VCOEFF(1,LSTART,K), LDVCO1, + $ A(LSTART,JOFF+1), LDA, ZERO, PCOEFF(1,1,K), + $ LDPCO1 ) + 10 CONTINUE +C +C Replace W(s) by Wbar(s) = s * V:L(s) - W(s). +C + NROW = NCOL +C + DO 30 K = LWORK, INDBLK + KPLUS = K + 1 +C + DO 20 J = 1, NCOL + CALL DSCAL( NROW, -ONE, PCOEFF(1,J,K), 1 ) + CALL DAXPY( NROW, ONE, VCOEFF(1,JOFF+J,KPLUS), 1, + $ PCOEFF(1,J,K), 1 ) + 20 CONTINUE +C + NROW = NBLK(K) + 30 CONTINUE +C + DO 40 J = 1, NCOL + CALL DSCAL( NROW, -ONE, PCOEFF(1,J,INPLUS), 1 ) + 40 CONTINUE +C + IF ( LWORK.NE.1 ) THEN +C +C If not final stage, use the upper triangular R (from A) +C to calculate V:L-1(s), finally storing this new block. +C + IOFF = JOFF - NBLK(LWORK-1) +C + DO 50 I = 1, NCOL + IF ( A(IOFF+I,JOFF+I).EQ.ZERO ) THEN +C +C Error return. +C + INFO = I + RETURN + END IF + 50 CONTINUE +C + NROW = NBLK(LWORK) +C + DO 60 K = LWORK, INPLUS + CALL DLACPY( 'Full', NROW, NCOL, PCOEFF(1,1,K), LDPCO1, + $ VCOEFF(1,IOFF+1,K), LDVCO1 ) + CALL DTRSM( 'Right', 'Upper', 'No Transpose', 'Non-unit', + $ NROW, NCOL, ONE, A(IOFF+1,JOFF+1), LDA, + $ VCOEFF(1,IOFF+1,K), LDVCO1 ) + NROW = NBLK(K) + 60 CONTINUE +C + END IF + 70 CONTINUE +C + RETURN +C *** Last line of TB03AY *** + END diff --git a/mex/sources/libslicot/TB04AD.f b/mex/sources/libslicot/TB04AD.f new file mode 100644 index 000000000..d864d1914 --- /dev/null +++ b/mex/sources/libslicot/TB04AD.f @@ -0,0 +1,395 @@ + SUBROUTINE TB04AD( ROWCOL, N, M, P, A, LDA, B, LDB, C, LDC, D, + $ LDD, NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, + $ LDUCO2, TOL1, TOL2, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the transfer matrix T(s) of a given state-space +C representation (A,B,C,D). T(s) is expressed as either row or +C column polynomial vectors over monic least common denominator +C polynomials. +C +C ARGUMENTS +C +C Mode Parameters +C +C ROWCOL CHARACTER*1 +C Indicates whether the transfer matrix T(s) is required +C as rows or columns over common denominators as follows: +C = 'R': T(s) is required as rows over common denominators; +C = 'C': T(s) is required as columns over common +C denominators. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the state-space representation, i.e. the +C order of the original state dynamics matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading NR-by-NR part of this array contains +C the upper block Hessenberg state dynamics matrix A of a +C transformed representation for the original system: this +C is completely controllable if ROWCOL = 'R', or completely +C observable if ROWCOL = 'C'. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), +C if ROWCOL = 'R', and (LDB,MAX(M,P)) if ROWCOL = 'C'. +C On entry, the leading N-by-M part of this array must +C contain the original input/state matrix B; if +C ROWCOL = 'C', the remainder of the leading N-by-MAX(M,P) +C part is used as internal workspace. +C On exit, the leading NR-by-M part of this array contains +C the transformed input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original state/output matrix C; if +C ROWCOL = 'C', the remainder of the leading MAX(M,P)-by-N +C part is used as internal workspace. +C On exit, the leading P-by-NR part of this array contains +C the transformed state/output matrix C. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,P) if ROWCOL = 'R'; +C LDC >= MAX(1,M,P) if ROWCOL = 'C'. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M), +C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. +C The leading P-by-M part of this array must contain the +C original direct transmission matrix D; if ROWCOL = 'C', +C this array is modified internally, but restored on exit, +C and the remainder of the leading MAX(M,P)-by-MAX(M,P) +C part is used as internal workspace. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P) if ROWCOL = 'R'; +C LDD >= MAX(1,M,P) if ROWCOL = 'C'. +C +C NR (output) INTEGER +C The order of the transformed state-space representation. +C +C INDEX (output) INTEGER array, dimension (porm), where porm = P, +C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. +C The degrees of the denominator polynomials. +C +C DCOEFF (output) DOUBLE PRECISION array, dimension (LDDCOE,N+1) +C The leading porm-by-kdcoef part of this array contains +C the coefficients of each denominator polynomial, where +C kdcoef = MAX(INDEX(I)) + 1. +C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of +C the I-th denominator polynomial, where K = 1,2,...,kdcoef. +C +C LDDCOE INTEGER +C The leading dimension of array DCOEFF. +C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; +C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. +C +C UCOEFF (output) DOUBLE PRECISION array, dimension +C (LDUCO1,LDUCO2,N+1) +C If ROWCOL = 'R' then porp = M, otherwise porp = P. +C The leading porm-by-porp-by-kdcoef part of this array +C contains the coefficients of the numerator matrix U(s). +C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; +C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. +C Thus for ROWCOL = 'R', U(s) = +C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). +C +C LDUCO1 INTEGER +C The leading dimension of array UCOEFF. +C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; +C LDUCO1 >= MAX(1,M) if ROWCOL = 'C'. +C +C LDUCO2 INTEGER +C The second dimension of array UCOEFF. +C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; +C LDUCO2 >= MAX(1,P) if ROWCOL = 'C'. +C +C Tolerances +C +C TOL1 DOUBLE PRECISION +C The tolerance to be used in determining the i-th row of +C T(s), where i = 1,2,...,porm. If the user sets TOL1 > 0, +C then the given value of TOL1 is used as an absolute +C tolerance; elements with absolute value less than TOL1 are +C considered neglijible. If the user sets TOL1 <= 0, then +C an implicitly computed, default tolerance, defined in +C the SLICOT Library routine TB01ZD, is used instead. +C +C TOL2 DOUBLE PRECISION +C The tolerance to be used to separate out a controllable +C subsystem of (A,B,C). If the user sets TOL2 > 0, then +C the given value of TOL2 is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL2 is considered to be of full rank. If the user sets +C TOL2 <= 0, then an implicitly computed, default tolerance, +C defined in the SLICOT Library routine TB01UD, is used +C instead. +C +C Workspace +C +C IWORK DOUBLE PRECISION array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*(N + 1) + MAX(N*MP + 2*N + MAX(N,MP), +C 3*MP, PM)), +C where MP = M, PM = P, if ROWCOL = 'R'; +C MP = P, PM = M, if ROWCOL = 'C'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The method for transfer matrices factorized by rows will be +C described here: T(s) factorized by columns is dealt with by +C operating on the dual of the original system. Each row of +C T(s) is simply a single-output relatively left prime polynomial +C matrix representation, so can be calculated by applying a +C simplified version of the Orthogonal Structure Theorem to a +C minimal state-space representation for the corresponding row of +C the given system. A minimal state-space representation is obtained +C using the Orthogonal Canonical Form to first separate out a +C completely controllable one for the overall system and then, for +C each row in turn, applying it again to the resulting dual SIMO +C (single-input multi-output) system. Note that the elements of the +C transformed matrix A so calculated are individually scaled in a +C way which guarantees a monic denominator polynomial. +C +C REFERENCES +C +C [1] Williams, T.W.C. +C An Orthogonal Structure Theorem for Linear Systems. +C Control Systems Research Group, Kingston Polytechnic, +C Internal Report 82/2, 1982. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. +C Supersedes Release 3.0 routine TB01QD. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Controllability, dual system, minimal realization, orthogonal +C canonical form, orthogonal transformation, polynomial matrix, +C transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ROWCOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, + $ LDUCO2, LDWORK, M, N, NR, P + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DCOEFF(LDDCOE,*), DWORK(*), + $ UCOEFF(LDUCO1,LDUCO2,*) +C .. Local Scalars .. + LOGICAL LROCOC, LROCOR + CHARACTER*1 JOBD + INTEGER I, IA, ITAU, J, JWORK, K, KDCOEF, MAXMP, MAXMPN, + $ MPLIM, MWORK, N1, PWORK +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, DLASET, DSWAP, TB01XD, TB04AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +C .. Executable Statements .. +C + INFO = 0 + LROCOR = LSAME( ROWCOL, 'R' ) + LROCOC = LSAME( ROWCOL, 'C' ) + MAXMP = MAX( M, P ) + MPLIM = MAX( 1, MAXMP ) + MAXMPN = MAX( MAXMP, N ) + N1 = MAX( 1, N ) + IF ( LROCOR ) THEN +C +C T(s) given as rows over common denominators. +C + PWORK = P + MWORK = M + ELSE +C +C T(s) given as columns over common denominators. +C + PWORK = M + MWORK = P + END IF +C +C Test the input scalar arguments. +C + IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -6 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -8 + ELSE IF( ( LROCOC .AND. LDC.LT.MPLIM ) + $ .OR. LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( ( LROCOC .AND. LDD.LT.MPLIM ) + $ .OR. LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN + INFO = -16 + ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) ) THEN + INFO = -18 + ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*( N + 1 ) + + $ MAX( N*MWORK + 2*N + MAX( N, MWORK ), + $ 3*MWORK, PWORK ) ) ) THEN + INFO = -24 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAXMPN.EQ.0 ) + $ RETURN +C + JOBD = 'D' + IA = 1 + ITAU = IA + N*N + JWORK = ITAU + N +C + IF ( LROCOC ) THEN +C +C Initialization for T(s) given as columns over common +C denominators. +C + CALL AB07MD( JOBD, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, + $ INFO ) + END IF +C +C Initialize polynomial matrix U(s) to zero. +C + DO 10 K = 1, N + 1 + CALL DLASET( 'Full', PWORK, MWORK, ZERO, ZERO, UCOEFF(1,1,K), + $ LDUCO1 ) + 10 CONTINUE +C +C Calculate T(s) by applying the Orthogonal Structure Theorem to +C each of the PWORK MISO subsystems (A,B,C:I,D:I) in turn. +C + CALL TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, LDD, + $ NR, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, LDUCO2, + $ DWORK(IA), N1, DWORK(ITAU), TOL1, TOL2, IWORK, + $ DWORK(JWORK), LDWORK-JWORK+1, INFO ) + DWORK(1) = DWORK(JWORK) + DBLE( JWORK-1 ) +C + IF ( LROCOC ) THEN +C +C For T(s) factorized by columns, return to original (dual of +C dual) system, and reorder the rows and columns to get an upper +C block Hessenberg state dynamics matrix. +C + CALL TB01XD( JOBD, N, MWORK, PWORK, IWORK(1)+IWORK(2)-1, N-1, + $ A, LDA, B, LDB, C, LDC, D, LDD, INFO ) +C + IF ( MPLIM.NE.1 ) THEN +C +C Also, transpose U(s) (not 1-by-1). +C + KDCOEF = 0 +C + DO 20 I = 1, PWORK + KDCOEF = MAX( KDCOEF, INDEX(I) ) + 20 CONTINUE +C + KDCOEF = KDCOEF + 1 +C + DO 50 K = 1, KDCOEF +C + DO 40 J = 1, MPLIM - 1 + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, + $ UCOEFF(J,J+1,K), LDUCO1 ) + 40 CONTINUE +C + 50 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of TB04AD *** + END diff --git a/mex/sources/libslicot/TB04AY.f b/mex/sources/libslicot/TB04AY.f new file mode 100644 index 000000000..afce62c3b --- /dev/null +++ b/mex/sources/libslicot/TB04AY.f @@ -0,0 +1,246 @@ + SUBROUTINE TB04AY( N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, + $ LDD, NCONT, INDEXD, DCOEFF, LDDCOE, UCOEFF, + $ LDUCO1, LDUCO2, AT, N1, TAU, TOL1, TOL2, IWORK, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Calculates the (PWORK x MWORK) transfer matrix T(s), in the form +C of polynomial row vectors over monic least common denominator +C polynomials, of a given state-space representation (ssr). Each +C such row of T(s) is simply a single-output relatively left prime +C polynomial matrix representation (pmr), so can be calculated by +C applying a simplified version of the Orthogonal Structure +C Theorem to a minimal ssr for the corresponding row of the given +C system: such an ssr is obtained by using the Orthogonal Canon- +C ical Form to first separate out a completely controllable one +C for the overall system and then, for each row in turn, applying +C it again to the resulting dual SIMO system. The Orthogonal +C Structure Theorem produces non-monic denominator and V:I(s) +C polynomials: this is avoided here by first scaling AT (the +C transpose of the controllable part of A, found in this routine) +C by suitable products of its sub-diagonal elements (these are then +C no longer needed, so freeing the entire lower triangle for +C storing the coefficients of V(s) apart from the leading 1's, +C which are treated implicitly). These polynomials are calculated +C in reverse order (IW = NMINL - 1,...,1), the monic denominator +C D:I(s) found exactly as if it were V:0(s), and finally the +C numerator vector U:I(s) obtained from the Orthogonal Structure +C Theorem relation. +C +C ****************************************************************** +C + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, + $ LDUCO2, LDWORK, MWORK, N, N1, NCONT, PWORK + DOUBLE PRECISION TOL1, TOL2 +C .. Array Arguments .. + INTEGER INDEXD(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), AT(N1,*), B(LDB,*), C(LDC,*), + $ D(LDD,*), DCOEFF(LDDCOE,*), DWORK(*), + $ UCOEFF(LDUCO1,LDUCO2,*), TAU(*) +C .. Local Scalars .. + INTEGER I, IB, IBI, IC, INDCON, IS, IV, IVMIN1, IWPLUS, + $ IZ, J, JWORK, K, L, LWORK, MAXM, NMINL, NPLUS, + $ WRKOPT + DOUBLE PRECISION TEMP +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, TB01UD, TB01ZD +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C +C Separate out controllable subsystem (of order NCONT). +C +C Workspace: MAX(N, 3*MWORK, PWORK). +C + CALL TB01UD( 'No Z', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, + $ NCONT, INDCON, IWORK, AT, 1, TAU, TOL2, IWORK(N+1), + $ DWORK, LDWORK, INFO ) + WRKOPT = INT( DWORK(1) ) +C + IS = 1 + IC = IS + NCONT + IZ = IC + IB = IC + NCONT + LWORK = IB + MWORK*NCONT + MAXM = MAX( 1, MWORK ) +C +C Calculate each row of T(s) in turn. +C + DO 140 I = 1, PWORK +C +C Form the dual of I-th NCONT-order MISO subsystem ... +C + CALL DCOPY( NCONT, C(I,1), LDC, DWORK(IC), 1 ) +C + DO 10 J = 1, NCONT + CALL DCOPY( NCONT, A(J,1), LDA, AT(1,J), 1 ) + CALL DCOPY( MWORK, B(J,1), LDB, DWORK((J-1)*MAXM+IB), 1 ) + 10 CONTINUE +C +C and separate out its controllable part, giving minimal +C state-space realization for row I. +C +C Workspace: MWORK*NCONT + 2*NCONT + MAX(NCONT,MWORK). +C + CALL TB01ZD( 'No Z', NCONT, MWORK, AT, N1, DWORK(IC), + $ DWORK(IB), MAXM, NMINL, DWORK(IZ), 1, TAU, TOL1, + $ DWORK(LWORK), LDWORK-LWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(LWORK) )+LWORK-1 ) +C +C Store degree of (monic) denominator, and leading coefficient +C vector of numerator. +C + INDEXD(I) = NMINL + DCOEFF(I,1) = ONE + CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,1), LDUCO1 ) +C + IF ( NMINL.EQ.1 ) THEN +C +C Finish off numerator, denominator for simple case NMINL=1. +C + TEMP = -AT(1,1) + DCOEFF(I,2) = TEMP + CALL DCOPY( MWORK, D(I,1), LDD, UCOEFF(I,1,2), LDUCO1 ) + CALL DSCAL( MWORK, TEMP, UCOEFF(I,1,2), LDUCO1 ) + CALL DAXPY( MWORK, DWORK(IC), DWORK(IB), 1, UCOEFF(I,1,2), + $ LDUCO1 ) + ELSE IF ( NMINL.GT.1 ) THEN +C +C Set up factors for scaling upper triangle of AT ... +C + CALL DCOPY( NMINL-1, AT(2,1), N1+1, DWORK(IC+1), 1 ) + NPLUS = NMINL + 1 +C + DO 20 L = IS, IS + NMINL - 1 + DWORK(L) = ONE + 20 CONTINUE +C +C and scale it, row by row, starting with row NMINL. +C + DO 40 JWORK = NMINL, 1, -1 +C + DO 30 J = JWORK, NMINL + AT(JWORK,J) = DWORK(IS+J-1)*AT(JWORK,J) + 30 CONTINUE +C +C Update scale factors for next row. +C + CALL DSCAL( NMINL-JWORK+1, DWORK(IC+JWORK-1), + $ DWORK(IS+JWORK-1), 1 ) + 40 CONTINUE +C +C Calculate each monic polynomial V:JWORK(s) in turn: +C K-th coefficient stored as AT(IV,K-1). +C + DO 70 IV = 2, NMINL + JWORK = NPLUS - IV + IWPLUS = JWORK + 1 + IVMIN1 = IV - 1 +C +C Set up coefficients due to leading 1's of existing +C V:I(s)'s. +C + DO 50 K = 1, IVMIN1 + AT(IV,K) = -AT(IWPLUS,JWORK+K) + 50 CONTINUE +C + IF ( IV.NE.2 ) THEN +C +C Then add contribution from s * V:JWORK+1(s) term. +C + CALL DAXPY( IV-2, ONE, AT(IVMIN1,1), N1, AT(IV,1), + $ N1 ) +C +C Finally, add effect of lower coefficients of existing +C V:I(s)'s. +C + DO 60 K = 2, IVMIN1 + AT(IV,K) = AT(IV,K) - DDOT( K-1, + $ AT(IWPLUS,JWORK+1), N1, + $ AT(IV-K+1,1), -(N1+1) ) + 60 CONTINUE +C + END IF + 70 CONTINUE +C +C Determine denominator polynomial D(s) as if it were V:0(s). +C + DO 80 K = 2, NPLUS + DCOEFF(I,K) = -AT(1,K-1) + 80 CONTINUE +C + CALL DAXPY( NMINL-1, ONE, AT(NMINL,1), N1, DCOEFF(I,2), + $ LDDCOE ) +C + DO 90 K = 3, NPLUS + DCOEFF(I,K) = DCOEFF(I,K) - DDOT( K-2, AT, N1, + $ AT(NMINL-K+3,1), -(N1+1) ) + 90 CONTINUE +C +C Scale (B' * Z), stored in DWORK(IB). +C + IBI = IB +C + DO 100 L = 1, NMINL + CALL DSCAL( MWORK, DWORK(IS+L-1), DWORK(IBI), 1 ) + IBI = IBI + MAXM + 100 CONTINUE +C +C Evaluate numerator polynomial vector (V(s) * B) + (D(s) +C * D:I): first set up coefficients due to D:I and leading +C 1's of V(s). +C + IBI = IB +C + DO 110 K = 2, NPLUS + CALL DCOPY( MWORK, DWORK(IBI), 1, UCOEFF(I,1,K), LDUCO1 ) + CALL DAXPY( MWORK, DCOEFF(I,K), D(I,1), LDD, + $ UCOEFF(I,1,K), LDUCO1 ) + IBI = IBI + MAXM + 110 CONTINUE +C +C Add contribution from lower coefficients of V(s). +C + DO 130 K = 3, NPLUS +C + DO 120 J = 1, MWORK + UCOEFF(I,J,K) = UCOEFF(I,J,K) + DDOT( K-2, + $ AT(NMINL-K+3,1), -(N1+1), + $ DWORK(IB+J-1), MAXM ) + 120 CONTINUE +C + 130 CONTINUE +C + END IF + 140 CONTINUE +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TB04AY *** + END diff --git a/mex/sources/libslicot/TB04BD.f b/mex/sources/libslicot/TB04BD.f new file mode 100644 index 000000000..0d8d5d0c0 --- /dev/null +++ b/mex/sources/libslicot/TB04BD.f @@ -0,0 +1,600 @@ + SUBROUTINE TB04BD( JOBD, ORDER, EQUIL, N, M, P, MD, A, LDA, B, + $ LDB, C, LDC, D, LDD, IGN, LDIGN, IGD, LDIGD, + $ GN, GD, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the transfer function matrix G of a state-space +C representation (A,B,C,D) of a linear time-invariant multivariable +C system, using the pole-zeros method. Each element of the transfer +C function matrix is returned in a cancelled, minimal form, with +C numerator and denominator polynomials stored either in increasing +C or decreasing order of the powers of the indeterminate. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state-space model: +C = 'D': D is present; +C = 'Z': D is assumed to be a zero matrix. +C +C ORDER CHARACTER*1 +C Specifies the order in which the polynomial coefficients +C are stored, as follows: +C = 'I': Increasing order of powers of the indeterminate; +C = 'D': Decreasing order of powers of the indeterminate. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system (A,B,C,D). N >= 0. +C +C M (input) INTEGER +C The number of the system inputs. M >= 0. +C +C P (input) INTEGER +C The number of the system outputs. P >= 0. +C +C MD (input) INTEGER +C The maximum degree of the polynomials in G, plus 1. An +C upper bound for MD is N+1. MD >= 1. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if EQUIL = 'S', the leading N-by-N part of this +C array contains the balanced matrix inv(S)*A*S, as returned +C by SLICOT Library routine TB01ID. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the contents of B are destroyed: all elements but +C those in the first row are set to zero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, if EQUIL = 'S', the leading P-by-N part of this +C array contains the balanced matrix C*S, as returned by +C SLICOT Library routine TB01ID. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this array must +C contain the matrix D. +C If JOBD = 'Z', the array D is not referenced. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C IGN (output) INTEGER array, dimension (LDIGN,M) +C The leading P-by-M part of this array contains the degrees +C of the numerator polynomials in the transfer function +C matrix G. Specifically, the (i,j) element of IGN contains +C the degree of the numerator polynomial of the transfer +C function G(i,j) from the j-th input to the i-th output. +C +C LDIGN INTEGER +C The leading dimension of array IGN. LDIGN >= max(1,P). +C +C IGD (output) INTEGER array, dimension (LDIGD,M) +C The leading P-by-M part of this array contains the degrees +C of the denominator polynomials in the transfer function +C matrix G. Specifically, the (i,j) element of IGD contains +C the degree of the denominator polynomial of the transfer +C function G(i,j). +C +C LDIGD INTEGER +C The leading dimension of array IGD. LDIGD >= max(1,P). +C +C GN (output) DOUBLE PRECISION array, dimension (P*M*MD) +C This array contains the coefficients of the numerator +C polynomials, Num(i,j), of the transfer function matrix G. +C The polynomials are stored in a column-wise order, i.e., +C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), +C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); +C MD memory locations are reserved for each polynomial, +C hence, the (i,j) polynomial is stored starting from the +C location ((j-1)*P+i-1)*MD+1. The coefficients appear in +C increasing or decreasing order of the powers of the +C indeterminate, according to ORDER. +C +C GD (output) DOUBLE PRECISION array, dimension (P*M*MD) +C This array contains the coefficients of the denominator +C polynomials, Den(i,j), of the transfer function matrix G. +C The polynomials are stored in the same way as the +C numerator polynomials. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the +C controllability of a single-input system (A,b) or (A',c'), +C where b and c' are columns in B and C' (C transposed). If +C the user sets TOL > 0, then the given value of TOL is used +C as an absolute tolerance; elements with absolute value +C less than TOL are considered neglijible. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used +C instead, where EPS is the machine precision (see LAPACK +C Library routine DLAMCH), and bc denotes the currently used +C column in B or C' (see METHOD). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*(N+P) + +C MAX( N + MAX( N,P ), N*(2*N+5))) +C If N >= P, N >= 1, the formula above can be written as +C LDWORK >= N*(3*N + P + 5). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm failed to converge when trying to +C compute the zeros of a transfer function; +C = 2: the QR algorithm failed to converge when trying to +C compute the poles of a transfer function. +C The errors INFO = 1 or 2 are unlikely to appear. +C +C METHOD +C +C The routine implements the pole-zero method proposed in [1]. +C This method is based on an algorithm for computing the transfer +C function of a single-input single-output (SISO) system. +C Let (A,b,c,d) be a SISO system. Its transfer function is computed +C as follows: +C +C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). +C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). +C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). +C 4) Compute the zeros of (Ao,bo,co,d). +C 5) Compute the gain of (Ao,bo,co,d). +C +C This algorithm can be implemented using only orthogonal +C transformations [1]. However, for better efficiency, the +C implementation in TB04BD uses one elementary transformation +C in Step 4 and r elementary transformations in Step 5 (to reduce +C an upper Hessenberg matrix to upper triangular form). These +C special elementary transformations are numerically stable +C in practice. +C +C In the multi-input multi-output (MIMO) case, the algorithm +C computes each element (i,j) of the transfer function matrix G, +C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 +C is performed once for each value of j (each column of B). The +C matrices Ac and Ao result in Hessenberg form. +C +C REFERENCES +C +C [1] Varga, A. and Sima, V. +C Numerically Stable Algorithm for Transfer Function Matrix +C Evaluation. +C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable in practice and requires about +C 20*N**3 floating point operations at most, but usually much less. +C +C FURTHER COMMENTS +C +C For maximum efficiency of index calculations, GN and GD are +C implemented as one-dimensional arrays. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C Partly based on the BIMASC Library routine TSMT1 by A. Varga. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, state-space representation, transfer function, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, JOBD, ORDER + DOUBLE PRECISION TOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDIGD, LDIGN, LDWORK, + $ M, MD, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), GD(*), GN(*) + INTEGER IGD(LDIGD,*), IGN(LDIGN,*), IWORK(*) +C .. Local Scalars .. + DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF, X + INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IIP, IM, + $ IP, IPM1, IRP, ITAU, ITAU1, IZ, J, JJ, JWORK, + $ JWORK1, K, L, NCONT, WRKOPT + LOGICAL ASCEND, DIJNZ, FNDEIG, WITHD +C .. Local Arrays .. + DOUBLE PRECISION Z(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, MC01PD, + $ MC01PY, TB01ID, TB01ZD, TB04BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + WITHD = LSAME( JOBD, 'D' ) + ASCEND = LSAME( ORDER, 'I' ) + IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN + INFO = -2 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( MD.LT.1 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -15 + ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN + INFO = -17 + ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN + INFO = -19 + ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + + $ MAX( N + MAX( N, P ), N*( 2*N + 5 ) ) ) + $ ) THEN + INFO = -25 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04BD', -INFO ) + RETURN + END IF +C +C Initialize GN and GD to zero. +C + Z(1) = ZERO + CALL DCOPY( P*M*MD, Z, 0, GN, 1 ) + CALL DCOPY( P*M*MD, Z, 0, GD, 1 ) +C +C Quick return if possible. +C + IF( MIN( N, P, M ).EQ.0 ) THEN + IF( MIN( P, M ).GT.0 ) THEN + K = 1 +C + DO 20 J = 1, M +C + DO 10 I = 1, P + IGN(I,J) = 0 + IGD(I,J) = 0 + IF ( WITHD ) + $ GN(K) = D(I,J) + GD(K) = ONE + K = K + MD + 10 CONTINUE +C + 20 CONTINUE +C + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Prepare the computation of the default tolerance. +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) THEN + EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) + ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + END IF +C +C Initializations. +C + IA = 1 + IC = IA + N*N + ITAU = IC + P*N + JWORK = ITAU + N + IAC = ITAU +C + K = 1 + DIJ = ZERO +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a +C diagonal scaling matrix. +C Workspace: need N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, IERR ) + END IF +C +C Compute the transfer function matrix of the system (A,B,C,D). +C + DO 80 J = 1, M +C +C Save A and C. +C Workspace: need W1 = N*(N+P). +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) +C +C Remove the uncontrollable part of the system (A,B(J),C). +C Workspace: need W1+N+MAX(N,P); +C prefer larger. +C + CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, + $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( J.EQ.1 ) + $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 +C + IB = IAC + NCONT*NCONT + ICC = IB + NCONT + ITAU1 = ICC + NCONT + IRP = ITAU1 + IIP = IRP + NCONT + IAS = IIP + NCONT + JWORK1 = IAS + NCONT*NCONT +C + DO 70 I = 1, P + IF ( WITHD ) + $ DIJ = D(I,J) + IF ( NCONT.GT.0 ) THEN +C +C Form the matrices of the state-space representation of +C the dual system for the controllable part. +C Workspace: need W2 = W1+N*(N+2). +C + CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, + $ DWORK(IAC), NCONT ) + CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) + CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) +C +C Remove the unobservable part of the system (A,B(J),C(I)). +C Workspace: need W2+2*N; +C prefer larger. +C + CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, + $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, + $ DWORK(ITAU1), TOL, DWORK(IIP), LDWORK-IIP+1, + $ IERR ) + IF ( I.EQ.1 ) + $ WRKOPT = MAX( WRKOPT, INT( DWORK(IIP) ) + IIP - 1 ) +C + IF ( IP.GT.0 ) THEN +C +C Save the state matrix of the minimal part. +C Workspace: need W3 = W2+N*(N+2). +C + CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, + $ DWORK(IAS), IP ) +C +C Compute the poles of the transfer function. +C Workspace: need W3+N; +C prefer larger. +C + CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, + $ DWORK(IAC), NCONT, DWORK(IRP), + $ DWORK(IIP), Z, 1, DWORK(JWORK1), + $ LDWORK-JWORK1+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WRKOPT = MAX( WRKOPT, + $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) +C +C Compute the zeros of the transfer function. +C + IPM1 = IP - 1 + DIJNZ = WITHD .AND. DIJ.NE.ZERO + FNDEIG = DIJNZ .OR. IPM1.GT.0 + IF ( .NOT.FNDEIG ) THEN + IZ = 0 + ELSE IF ( DIJNZ ) THEN +C +C Add the contribution due to D(i,j). +C Note that the matrix whose eigenvalues have to +C be computed remains in an upper Hessenberg form. +C + IZ = IP + CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, + $ DWORK(IAC), NCONT ) + CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, + $ DWORK(IAC), NCONT ) + ELSE + IF( TOL.LE.ZERO ) + $ TOLDEF = EPSN*MAX( ANORM, + $ DLANGE( 'Frobenius', IP, 1, + $ DWORK(IB), 1, DWORK ) + $ ) +C + DO 30 IM = 1, IPM1 + IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 + 30 CONTINUE +C + IZ = 0 + GO TO 50 +C + 40 CONTINUE +C +C Restore (part of) the saved state matrix. +C + IZ = IP - IM + CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), + $ IP, DWORK(IAC), NCONT ) +C +C Apply the output injection. +C + CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ + $ DWORK(IB+IM-1), DWORK(IB+IM), 1, + $ DWORK(IAC), NCONT ) + END IF +C + IF ( FNDEIG ) THEN +C +C Find the zeros. +C Workspace: need W3+N; +C prefer larger. +C + CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, + $ IZ, DWORK(IAC), NCONT, GN(K), GD(K), + $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, + $ IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + END IF +C +C Compute the gain. +C + 50 CONTINUE + IF ( DIJNZ ) THEN + X = DIJ + ELSE + CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), + $ DWORK(IB), DIJ, DWORK(IRP), + $ DWORK(IIP), GN(K), GD(K), X, IWORK ) + END IF +C +C Form the numerator coefficients in increasing or +C decreasing powers of the indeterminate. +C IAS is used here as pointer to the workspace. +C + IF ( ASCEND ) THEN + CALL MC01PD( IZ, GN(K), GD(K), DWORK(IB), + $ DWORK(IAS), IERR ) + ELSE + CALL MC01PY( IZ, GN(K), GD(K), DWORK(IB), + $ DWORK(IAS), IERR ) + END IF + JJ = K +C + DO 60 L = IB, IB + IZ + GN(JJ) = DWORK(L)*X + JJ = JJ + 1 + 60 CONTINUE +C +C Form the denominator coefficients. +C + IF ( ASCEND ) THEN + CALL MC01PD( IP, DWORK(IRP), DWORK(IIP), GD(K), + $ DWORK(IAS), IERR ) + ELSE + CALL MC01PY( IP, DWORK(IRP), DWORK(IIP), GD(K), + $ DWORK(IAS), IERR ) + END IF + IGN(I,J) = IZ + IGD(I,J) = IP + ELSE +C +C Null element. +C + IGN(I,J) = 0 + IGD(I,J) = 0 + GN(K) = DIJ + GD(K) = ONE + END IF +C + ELSE +C +C Null element. +C + IGN(I,J) = 0 + IGD(I,J) = 0 + GN(K) = DIJ + GD(K) = ONE + END IF +C + K = K + MD + 70 CONTINUE +C + 80 CONTINUE +C + RETURN +C *** Last line of TB04BD *** + END diff --git a/mex/sources/libslicot/TB04BV.f b/mex/sources/libslicot/TB04BV.f new file mode 100644 index 000000000..10b58b592 --- /dev/null +++ b/mex/sources/libslicot/TB04BV.f @@ -0,0 +1,343 @@ + SUBROUTINE TB04BV( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, + $ GD, D, LDD, TOL, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To separate the strictly proper part G0 from the constant part D +C of an P-by-M proper transfer function matrix G. +C +C ARGUMENTS +C +C Mode Parameters +C +C ORDER CHARACTER*1 +C Specifies the order in which the polynomial coefficients +C of the transfer function matrix are stored, as follows: +C = 'I': Increasing order of powers of the indeterminate; +C = 'D': Decreasing order of powers of the indeterminate. +C +C Input/Output Parameters +C +C P (input) INTEGER +C The number of the system outputs. P >= 0. +C +C M (input) INTEGER +C The number of the system inputs. M >= 0. +C +C MD (input) INTEGER +C The maximum degree of the polynomials in G, plus 1, i.e., +C MD = MAX(IGD(I,J)) + 1. +C I,J +C +C IGN (input/output) INTEGER array, dimension (LDIGN,M) +C On entry, the leading P-by-M part of this array must +C contain the degrees of the numerator polynomials in G: +C the (i,j) element of IGN must contain the degree of the +C numerator polynomial of the polynomial ratio G(i,j). +C On exit, the leading P-by-M part of this array contains +C the degrees of the numerator polynomials in G0. +C +C LDIGN INTEGER +C The leading dimension of array IGN. LDIGN >= max(1,P). +C +C IGD (input) INTEGER array, dimension (LDIGD,M) +C The leading P-by-M part of this array must contain the +C degrees of the denominator polynomials in G (and G0): +C the (i,j) element of IGD contains the degree of the +C denominator polynomial of the polynomial ratio G(i,j). +C +C LDIGD INTEGER +C The leading dimension of array IGD. LDIGD >= max(1,P). +C +C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) +C On entry, this array must contain the coefficients of the +C numerator polynomials, Num(i,j), of the transfer function +C matrix G. The polynomials are stored in a column-wise +C order, i.e., Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), +C Num(2,2), ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., +C Num(P,M); MD memory locations are reserved for each +C polynomial, hence, the (i,j) polynomial is stored starting +C from the location ((j-1)*P+i-1)*MD+1. The coefficients +C appear in increasing or decreasing order of the powers +C of the indeterminate, according to ORDER. +C On exit, this array contains the coefficients of the +C numerator polynomials of the strictly proper part G0 of +C the transfer function matrix G, stored similarly. +C +C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) +C This array must contain the coefficients of the +C denominator polynomials, Den(i,j), of the transfer +C function matrix G. The polynomials are stored as for the +C numerator polynomials. +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array contains the +C matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= max(1,P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the degrees of +C the numerators Num0(i,j) of the strictly proper part of +C the transfer function matrix G. If the user sets TOL > 0, +C then the given value of TOL is used as an absolute +C tolerance; the leading coefficients with absolute value +C less than TOL are considered neglijible. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = IGN(i,j)*EPS*NORM( Num(i,j) ) is used +C instead, where EPS is the machine precision (see LAPACK +C Library routine DLAMCH), and NORM denotes the infinity +C norm (the maximum coefficient in absolute value). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the transfer function matrix is not proper; +C = 2: if a denominator polynomial is null. +C +C METHOD +C +C The (i,j) entry of the real matrix D is zero, if the degree of +C Num(i,j), IGN(i,j), is less than the degree of Den(i,j), IGD(i,j), +C and it is given by the ratio of the leading coefficients of +C Num(i,j) and Den(i,j), if IGN(i,j) is equal to IGD(i,j), +C for i = 1 : P, and for j = 1 : M. +C +C FURTHER COMMENTS +C +C For maximum efficiency of index calculations, GN and GD are +C implemented as one-dimensional arrays. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C Based on the BIMASC Library routine TMPRP by A. Varga. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C State-space representation, transfer function. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ORDER + DOUBLE PRECISION TOL + INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P +C .. Array Arguments .. + DOUBLE PRECISION D(LDD,*), GD(*), GN(*) + INTEGER IGD(LDIGD,*), IGN(LDIGN,*) +C .. Local Scalars .. + LOGICAL ASCEND + INTEGER I, II, J, K, KK, KM, ND, NN + DOUBLE PRECISION DIJ, EPS, TOLDEF +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + ASCEND = LSAME( ORDER, 'I' ) + IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN + INFO = -1 + ELSE IF( P.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( MD.LT.1 ) THEN + INFO = -4 + ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN + INFO = -6 + ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04BV', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( P, M ).EQ.0 ) + $ RETURN +C +C Prepare the computation of the default tolerance. +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) + $ EPS = DLAMCH( 'Epsilon' ) +C + K = 1 +C + IF ( ASCEND ) THEN +C +C Polynomial coefficients are stored in increasing order. +C + DO 40 J = 1, M +C + DO 30 I = 1, P + NN = IGN(I,J) + ND = IGD(I,J) + IF ( NN.GT.ND ) THEN +C +C Error return: the transfer function matrix is +C not proper. +C + INFO = 1 + RETURN + ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) + $ THEN + D(I,J) = ZERO + ELSE +C +C Here NN = ND. +C + KK = K + NN +C + IF ( GD(KK).EQ.ZERO ) THEN +C +C Error return: the denominator is null. +C + INFO = 2 + RETURN + ENDIF +C + DIJ = GN(KK) / GD(KK) + D(I,J) = DIJ + GN(KK) = ZERO + IF ( NN.GT.0 ) THEN + CALL DAXPY( NN, -DIJ, GD(K), 1, GN(K), 1 ) + IF ( TOL.LE.ZERO ) + $ TOLDEF = DBLE( NN )*EPS* + $ ABS( GN(IDAMAX( NN, GN(K), 1 ) ) ) + KM = NN + DO 10 II = 1, KM + KK = KK - 1 + NN = NN - 1 + IF ( ABS( GN(KK) ).GT.TOLDEF ) + $ GO TO 20 + 10 CONTINUE +C + 20 CONTINUE +C + IGN(I,J) = NN + ENDIF + ENDIF + K = K + MD + 30 CONTINUE +C + 40 CONTINUE +C + ELSE +C +C Polynomial coefficients are stored in decreasing order. +C + DO 90 J = 1, M +C + DO 80 I = 1, P + NN = IGN(I,J) + ND = IGD(I,J) + IF ( NN.GT.ND ) THEN +C +C Error return: the transfer function matrix is +C not proper. +C + INFO = 1 + RETURN + ELSE IF ( NN.LT.ND .OR. ( ND.EQ.0 .AND. GN(K).EQ.ZERO ) ) + $ THEN + D(I,J) = ZERO + ELSE +C +C Here NN = ND. +C + KK = K +C + IF ( GD(KK).EQ.ZERO ) THEN +C +C Error return: the denominator is null. +C + INFO = 2 + RETURN + ENDIF +C + DIJ = GN(KK) / GD(KK) + D(I,J) = DIJ + GN(KK) = ZERO + IF ( NN.GT.0 ) THEN + CALL DAXPY( NN, -DIJ, GD(K+1), 1, GN(K+1), 1 ) + IF ( TOL.LE.ZERO ) + $ TOLDEF = DBLE( NN )*EPS* + $ ABS( GN(IDAMAX( NN, GN(K+1), 1 ) ) ) + KM = NN + DO 50 II = 1, KM + KK = KK + 1 + NN = NN - 1 + IF ( ABS( GN(KK) ).GT.TOLDEF ) + $ GO TO 60 + 50 CONTINUE +C + 60 CONTINUE +C + IGN(I,J) = NN + DO 70 II = 0, NN + GN(K+II) = GN(KK+II) + 70 CONTINUE +C + ENDIF + ENDIF + K = K + MD + 80 CONTINUE +C + 90 CONTINUE +C + ENDIF +C + RETURN +C *** Last line of TB04BV *** + END diff --git a/mex/sources/libslicot/TB04BW.f b/mex/sources/libslicot/TB04BW.f new file mode 100644 index 000000000..7fb2a3217 --- /dev/null +++ b/mex/sources/libslicot/TB04BW.f @@ -0,0 +1,280 @@ + SUBROUTINE TB04BW( ORDER, P, M, MD, IGN, LDIGN, IGD, LDIGD, GN, + $ GD, D, LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the sum of an P-by-M rational matrix G and a real +C P-by-M matrix D. +C +C ARGUMENTS +C +C Mode Parameters +C +C ORDER CHARACTER*1 +C Specifies the order in which the polynomial coefficients +C of the rational matrix are stored, as follows: +C = 'I': Increasing order of powers of the indeterminate; +C = 'D': Decreasing order of powers of the indeterminate. +C +C Input/Output Parameters +C +C P (input) INTEGER +C The number of the system outputs. P >= 0. +C +C M (input) INTEGER +C The number of the system inputs. M >= 0. +C +C MD (input) INTEGER +C The maximum degree of the polynomials in G, plus 1, i.e., +C MD = MAX(IGN(I,J),IGD(I,J)) + 1. +C I,J +C +C IGN (input/output) INTEGER array, dimension (LDIGN,M) +C On entry, the leading P-by-M part of this array must +C contain the degrees of the numerator polynomials in G: +C the (i,j) element of IGN must contain the degree of the +C numerator polynomial of the polynomial ratio G(i,j). +C On exit, the leading P-by-M part of this array contains +C the degrees of the numerator polynomials in G + D. +C +C LDIGN INTEGER +C The leading dimension of array IGN. LDIGN >= max(1,P). +C +C IGD (input) INTEGER array, dimension (LDIGD,M) +C The leading P-by-M part of this array must contain the +C degrees of the denominator polynomials in G (and G + D): +C the (i,j) element of IGD contains the degree of the +C denominator polynomial of the polynomial ratio G(i,j). +C +C LDIGD INTEGER +C The leading dimension of array IGD. LDIGD >= max(1,P). +C +C GN (input/output) DOUBLE PRECISION array, dimension (P*M*MD) +C On entry, this array must contain the coefficients of the +C numerator polynomials, Num(i,j), of the rational matrix G. +C The polynomials are stored in a column-wise order, i.e., +C Num(1,1), Num(2,1), ..., Num(P,1), Num(1,2), Num(2,2), +C ..., Num(P,2), ..., Num(1,M), Num(2,M), ..., Num(P,M); +C MD memory locations are reserved for each polynomial, +C hence, the (i,j) polynomial is stored starting from the +C location ((j-1)*P+i-1)*MD+1. The coefficients appear in +C increasing or decreasing order of the powers of the +C indeterminate, according to ORDER. +C On exit, this array contains the coefficients of the +C numerator polynomials of the rational matrix G + D, +C stored similarly. +C +C GD (input) DOUBLE PRECISION array, dimension (P*M*MD) +C This array must contain the coefficients of the +C denominator polynomials, Den(i,j), of the rational +C matrix G. The polynomials are stored as for the +C numerator polynomials. +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C matrix D. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= max(1,P). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The (i,j) entry of the real matrix D is added to the (i,j) entry +C of the matrix G, g(i,j), which is a ratio of two polynomials, +C for i = 1 : P, and for j = 1 : M. If g(i,j) = 0, it is assumed +C that its denominator is 1. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable. +C +C FURTHER COMMENTS +C +C Often, the rational matrix G is found from a state-space +C representation (A,B,C), and D corresponds to the direct +C feedthrough matrix of the system. The sum G + D gives the +C transfer function matrix of the system (A,B,C,D). +C For maximum efficiency of index calculations, GN and GD are +C implemented as one-dimensional arrays. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C Based on the BIMASC Library routine TMCADD by A. Varga. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004. +C +C KEYWORDS +C +C State-space representation, transfer function. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER ORDER + INTEGER INFO, LDD, LDIGD, LDIGN, M, MD, P +C .. Array Arguments .. + DOUBLE PRECISION D(LDD,*), GD(*), GN(*) + INTEGER IGD(LDIGD,*), IGN(LDIGN,*) +C .. Local Scalars .. + LOGICAL ASCEND + INTEGER I, II, J, K, KK, KM, ND, NN + DOUBLE PRECISION DIJ +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + ASCEND = LSAME( ORDER, 'I' ) + IF( .NOT.ASCEND .AND. .NOT.LSAME( ORDER, 'D' ) ) THEN + INFO = -1 + ELSE IF( P.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( MD.LT.1 ) THEN + INFO = -4 + ELSE IF( LDIGN.LT.MAX( 1, P ) ) THEN + INFO = -6 + ELSE IF( LDIGD.LT.MAX( 1, P ) ) THEN + INFO = -8 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04BW', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( MIN( P, M ).EQ.0 ) + $ RETURN +C + K = 1 +C + IF ( ASCEND ) THEN +C +C Polynomial coefficients are stored in increasing order. +C + DO 30 J = 1, M +C + DO 20 I = 1, P + DIJ = D(I,J) + IF ( DIJ.NE.ZERO ) THEN + NN = IGN(I,J) + ND = IGD(I,J) + IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN + IF ( GN(K).EQ.ZERO ) THEN + GN(K) = DIJ + ELSE + GN(K) = GN(K) + DIJ*GD(K) + ENDIF + ELSE + KM = MIN( NN, ND ) + 1 + CALL DAXPY( KM, DIJ, GD(K), 1, GN(K), 1 ) + IF ( NN.LT.ND ) THEN +C + DO 10 II = K + KM, K + ND + GN(II) = DIJ*GD(II) + 10 CONTINUE +C + IGN(I,J) = ND + ENDIF + ENDIF + ENDIF + K = K + MD + 20 CONTINUE +C + 30 CONTINUE +C + ELSE +C +C Polynomial coefficients are stored in decreasing order. +C + DO 60 J = 1, M +C + DO 50 I = 1, P + DIJ = D(I,J) + IF ( DIJ.NE.ZERO ) THEN + NN = IGN(I,J) + ND = IGD(I,J) + IF ( NN.EQ.0 .AND. ND.EQ.0 ) THEN + IF ( GN(K).EQ.ZERO ) THEN + GN(K) = DIJ + ELSE + GN(K) = GN(K) + DIJ*GD(K) + ENDIF + ELSE + KM = MIN( NN, ND ) + 1 + IF ( NN.LT.ND ) THEN + KK = K + ND - NN +C + DO 35 II = K + NN, K, -1 + GN(II+ND-NN) = GN(II) + 35 CONTINUE +C + DO 40 II = K, KK - 1 + GN(II) = DIJ*GD(II) + 40 CONTINUE +C + IGN(I,J) = ND + CALL DAXPY( KM, DIJ, GD(KK), 1, GN(KK), 1 ) + ELSE + KK = K + NN - ND + CALL DAXPY( KM, DIJ, GD(K), 1, GN(KK), 1 ) + ENDIF + ENDIF + ENDIF + K = K + MD + 50 CONTINUE +C + 60 CONTINUE +C + ENDIF +C + RETURN +C *** Last line of TB04BW *** + END diff --git a/mex/sources/libslicot/TB04BX.f b/mex/sources/libslicot/TB04BX.f new file mode 100644 index 000000000..ff0e004f1 --- /dev/null +++ b/mex/sources/libslicot/TB04BX.f @@ -0,0 +1,246 @@ + SUBROUTINE TB04BX( IP, IZ, A, LDA, B, C, D, PR, PI, ZR, ZI, GAIN, + $ IWORK ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the gain of a single-input single-output linear system, +C given its state-space representation (A,b,c,d), and its poles and +C zeros. The matrix A is assumed to be in an upper Hessenberg form. +C The gain is computed using the formula +C +C -1 IP IZ +C g = (c*( S0*I - A ) *b + d)*Prod( S0 - Pi )/Prod( S0 - Zi ) , +C i=1 i=1 (1) +C +C where Pi, i = 1 : IP, and Zj, j = 1 : IZ, are the poles and zeros, +C respectively, and S0 is a real scalar different from all poles and +C zeros. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C IP (input) INTEGER +C The number of the system poles. IP >= 0. +C +C IZ (input) INTEGER +C The number of the system zeros. IZ >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,IP) +C On entry, the leading IP-by-IP part of this array must +C contain the state dynamics matrix A in an upper Hessenberg +C form. The elements below the second diagonal are not +C referenced. +C On exit, the leading IP-by-IP upper Hessenberg part of +C this array contains the LU factorization of the matrix +C A - S0*I, as computed by SLICOT Library routine MB02SD. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= max(1,IP). +C +C B (input/output) DOUBLE PRECISION array, dimension (IP) +C On entry, this array must contain the system input +C vector b. +C On exit, this array contains the solution of the linear +C system ( A - S0*I )x = b . +C +C C (input) DOUBLE PRECISION array, dimension (IP) +C This array must contain the system output vector c. +C +C D (input) DOUBLE PRECISION +C The variable must contain the system feedthrough scalar d. +C +C PR (input) DOUBLE PRECISION array, dimension (IP) +C This array must contain the real parts of the system +C poles. Pairs of complex conjugate poles must be stored in +C consecutive memory locations. +C +C PI (input) DOUBLE PRECISION array, dimension (IP) +C This array must contain the imaginary parts of the system +C poles. +C +C ZR (input) DOUBLE PRECISION array, dimension (IZ) +C This array must contain the real parts of the system +C zeros. Pairs of complex conjugate zeros must be stored in +C consecutive memory locations. +C +C ZI (input) DOUBLE PRECISION array, dimension (IZ) +C This array must contain the imaginary parts of the system +C zeros. +C +C GAIN (output) DOUBLE PRECISION +C The gain of the linear system (A,b,c,d), given by (1). +C +C Workspace +C +C IWORK INTEGER array, dimension (IP) +C On exit, it contains the pivot indices; for 1 <= i <= IP, +C row i of the matrix A - S0*I was interchanged with +C row IWORK(i). +C +C METHOD +C +C The routine implements the method presented in [1]. A suitable +C value of S0 is chosen based on the system poles and zeros. +C Then, the LU factorization of the upper Hessenberg, nonsingular +C matrix A - S0*I is computed and used to solve the linear system +C in (1). +C +C REFERENCES +C +C [1] Varga, A. and Sima, V. +C Numerically Stable Algorithm for Transfer Function Matrix +C Evaluation. +C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable in practice and requires +C O(IP*IP) floating point operations. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C Partly based on the BIMASC Library routine GAIN by A. Varga. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, state-space representation, transfer function, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, P1, ONEP1 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ P1 = 0.1D0, ONEP1 = 1.1D0 ) +C .. Scalar Arguments .. + DOUBLE PRECISION D, GAIN + INTEGER IP, IZ, LDA +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(*), C(*), PI(*), PR(*), ZI(*), + $ ZR(*) + INTEGER IWORK(*) +C .. Local Scalars .. + INTEGER I, INFO + DOUBLE PRECISION S0, S +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL MB02RD, MB02SD +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX +C .. +C .. Executable Statements .. +C +C For efficiency, the input scalar parameters are not checked. +C +C Quick return if possible. +C + IF( IP.EQ.0 ) THEN + GAIN = ZERO + RETURN + END IF +C +C Compute a suitable value for S0 . +C + S0 = ZERO +C + DO 10 I = 1, IP + S = ABS( PR(I) ) + IF ( PI(I).NE.ZERO ) + $ S = S + ABS( PI(I) ) + S0 = MAX( S0, S ) + 10 CONTINUE +C + DO 20 I = 1, IZ + S = ABS( ZR(I) ) + IF ( ZI(I).NE.ZERO ) + $ S = S + ABS( ZI(I) ) + S0 = MAX( S0, S ) + 20 CONTINUE +C + S0 = TWO*S0 + P1 + IF ( S0.LE.ONE ) + $ S0 = ONEP1 +C +C Form A - S0*I . +C + DO 30 I = 1, IP + A(I,I) = A(I,I) - S0 + 30 CONTINUE +C +C Compute the LU factorization of the matrix A - S0*I +C (guaranteed to be nonsingular). +C + CALL MB02SD( IP, A, LDA, IWORK, INFO ) +C +C Solve the linear system (A - S0*I)*x = b . +C + CALL MB02RD( 'No Transpose', IP, 1, A, LDA, IWORK, B, IP, INFO ) +C -1 +C Compute c*(S0*I - A) *b + d . +C + GAIN = D - DDOT( IP, C, 1, B, 1 ) +C +C Multiply by the products in terms of poles and zeros in (1). +C + I = 1 +C +C WHILE ( I <= IP ) DO +C + 40 IF ( I.LE.IP ) THEN + IF ( PI(I).EQ.ZERO ) THEN + GAIN = GAIN*( S0 - PR(I) ) + I = I + 1 + ELSE + GAIN = GAIN*( S0*( S0 - TWO*PR(I) ) + PR(I)**2 + PI(I)**2 ) + I = I + 2 + END IF + GO TO 40 + END IF +C +C END WHILE 40 +C + I = 1 +C +C WHILE ( I <= IZ ) DO +C + 50 IF ( I.LE.IZ ) THEN + IF ( ZI(I).EQ.ZERO ) THEN + GAIN = GAIN/( S0 - ZR(I) ) + I = I + 1 + ELSE + GAIN = GAIN/( S0*( S0 - TWO*ZR(I) ) + ZR(I)**2 + ZI(I)**2 ) + I = I + 2 + END IF + GO TO 50 + END IF +C +C END WHILE 50 +C + RETURN +C *** Last line of TB04BX *** + END diff --git a/mex/sources/libslicot/TB04CD.f b/mex/sources/libslicot/TB04CD.f new file mode 100644 index 000000000..012548bec --- /dev/null +++ b/mex/sources/libslicot/TB04CD.f @@ -0,0 +1,568 @@ + SUBROUTINE TB04CD( JOBD, EQUIL, N, M, P, NPZ, A, LDA, B, LDB, C, + $ LDC, D, LDD, NZ, LDNZ, NP, LDNP, ZEROSR, + $ ZEROSI, POLESR, POLESI, GAINS, LDGAIN, TOL, + $ IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the transfer function matrix G of a state-space +C representation (A,B,C,D) of a linear time-invariant multivariable +C system, using the pole-zeros method. The transfer function matrix +C is returned in a minimal pole-zero-gain form. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBD CHARACTER*1 +C Specifies whether or not a non-zero matrix D appears in +C the given state-space model: +C = 'D': D is present; +C = 'Z': D is assumed to be a zero matrix. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily +C equilibrate the triplet (A,B,C) as follows: +C = 'S': perform equilibration (scaling); +C = 'N': do not perform equilibration. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the system (A,B,C,D). N >= 0. +C +C M (input) INTEGER +C The number of the system inputs. M >= 0. +C +C P (input) INTEGER +C The number of the system outputs. P >= 0. +C +C NPZ (input) INTEGER +C The maximum number of poles or zeros of the single-input +C single-output channels in the system. An upper bound +C for NPZ is N. NPZ >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, if EQUIL = 'S', the leading N-by-N part of this +C array contains the balanced matrix inv(S)*A*S, as returned +C by SLICOT Library routine TB01ID. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the contents of B are destroyed: all elements but +C those in the first row are set to zero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, if EQUIL = 'S', the leading P-by-N part of this +C array contains the balanced matrix C*S, as returned by +C SLICOT Library routine TB01ID. +C If EQUIL = 'N', this array is unchanged on exit. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C If JOBD = 'D', the leading P-by-M part of this array must +C contain the matrix D. +C If JOBD = 'Z', the array D is not referenced. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P), if JOBD = 'D'; +C LDD >= 1, if JOBD = 'Z'. +C +C NZ (output) INTEGER array, dimension (LDNZ,M) +C The leading P-by-M part of this array contains the numbers +C of zeros of the elements of the transfer function +C matrix G. Specifically, the (i,j) element of NZ contains +C the number of zeros of the transfer function G(i,j) from +C the j-th input to the i-th output. +C +C LDNZ INTEGER +C The leading dimension of array NZ. LDNZ >= max(1,P). +C +C NP (output) INTEGER array, dimension (LDNP,M) +C The leading P-by-M part of this array contains the numbers +C of poles of the elements of the transfer function +C matrix G. Specifically, the (i,j) element of NP contains +C the number of poles of the transfer function G(i,j). +C +C LDNP INTEGER +C The leading dimension of array NP. LDNP >= max(1,P). +C +C ZEROSR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) +C This array contains the real parts of the zeros of the +C transfer function matrix G. The real parts of the zeros +C are stored in a column-wise order, i.e., for the transfer +C functions (1,1), (2,1), ..., (P,1), (1,2), (2,2), ..., +C (P,2), ..., (1,M), (2,M), ..., (P,M); NPZ memory locations +C are reserved for each transfer function, hence, the real +C parts of the zeros for the (i,j) transfer function +C are stored starting from the location ((j-1)*P+i-1)*NPZ+1. +C Pairs of complex conjugate zeros are stored in consecutive +C memory locations. Note that only the first NZ(i,j) entries +C are initialized for the (i,j) transfer function. +C +C ZEROSI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) +C This array contains the imaginary parts of the zeros of +C the transfer function matrix G, stored in a similar way +C as the real parts of the zeros. +C +C POLESR (output) DOUBLE PRECISION array, dimension (P*M*NPZ) +C This array contains the real parts of the poles of the +C transfer function matrix G, stored in the same way as +C the zeros. Note that only the first NP(i,j) entries are +C initialized for the (i,j) transfer function. +C +C POLESI (output) DOUBLE PRECISION array, dimension (P*M*NPZ) +C This array contains the imaginary parts of the poles of +C the transfer function matrix G, stored in the same way as +C the poles. +C +C GAINS (output) DOUBLE PRECISION array, dimension (LDGAIN,M) +C The leading P-by-M part of this array contains the gains +C of the transfer function matrix G. Specifically, +C GAINS(i,j) contains the gain of the transfer function +C G(i,j). +C +C LDGAIN INTEGER +C The leading dimension of array GAINS. LDGAIN >= max(1,P). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the +C controllability of a single-input system (A,b) or (A',c'), +C where b and c' are columns in B and C' (C transposed). If +C the user sets TOL > 0, then the given value of TOL is used +C as an absolute tolerance; elements with absolute value +C less than TOL are considered neglijible. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*EPS*MAX( NORM(A), NORM(bc) ) is used +C instead, where EPS is the machine precision (see LAPACK +C Library routine DLAMCH), and bc denotes the currently used +C column in B or C' (see METHOD). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N*(N+P) + +C MAX( N + MAX( N,P ), N*(2*N+3))) +C If N >= P, N >= 1, the formula above can be written as +C LDWORK >= N*(3*N + P + 3). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: the QR algorithm failed to converge when trying to +C compute the zeros of a transfer function; +C = 2: the QR algorithm failed to converge when trying to +C compute the poles of a transfer function. +C The errors INFO = 1 or 2 are unlikely to appear. +C +C METHOD +C +C The routine implements the pole-zero method proposed in [1]. +C This method is based on an algorithm for computing the transfer +C function of a single-input single-output (SISO) system. +C Let (A,b,c,d) be a SISO system. Its transfer function is computed +C as follows: +C +C 1) Find a controllable realization (Ac,bc,cc) of (A,b,c). +C 2) Find an observable realization (Ao,bo,co) of (Ac,bc,cc). +C 3) Compute the r eigenvalues of Ao (the poles of (Ao,bo,co)). +C 4) Compute the zeros of (Ao,bo,co,d). +C 5) Compute the gain of (Ao,bo,co,d). +C +C This algorithm can be implemented using only orthogonal +C transformations [1]. However, for better efficiency, the +C implementation in TB04CD uses one elementary transformation +C in Step 4 and r elementary transformations in Step 5 (to reduce +C an upper Hessenberg matrix to upper triangular form). These +C special elementary transformations are numerically stable +C in practice. +C +C In the multi-input multi-output (MIMO) case, the algorithm +C computes each element (i,j) of the transfer function matrix G, +C for i = 1 : P, and for j = 1 : M. For efficiency reasons, Step 1 +C is performed once for each value of j (each column of B). The +C matrices Ac and Ao result in Hessenberg form. +C +C REFERENCES +C +C [1] Varga, A. and Sima, V. +C Numerically Stable Algorithm for Transfer Function Matrix +C Evaluation. +C Int. J. Control, vol. 33, nr. 6, pp. 1123-1133, 1981. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically stable in practice and requires about +C 20*N**3 floating point operations at most, but usually much less. +C +C CONTRIBUTORS +C +C V. Sima, Research Institute for Informatics, Bucharest, May 2002. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, state-space representation, transfer function, zeros. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, C100 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, C100 = 100.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, JOBD + DOUBLE PRECISION TOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDGAIN, LDNP, LDNZ, + $ LDWORK, M, N, NPZ, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), GAINS(LDGAIN,*), POLESI(*), + $ POLESR(*), ZEROSI(*), ZEROSR(*) + INTEGER IWORK(*), NP(LDNP,*), NZ(LDNZ,*) +C .. Local Scalars .. + DOUBLE PRECISION ANORM, DIJ, EPSN, MAXRED, TOLDEF + INTEGER I, IA, IAC, IAS, IB, IC, ICC, IERR, IM, IP, + $ IPM1, ITAU, ITAU1, IZ, J, JWK, JWORK, JWORK1, + $ K, NCONT, WRKOPT + LOGICAL DIJNZ, FNDEIG, WITHD +C .. Local Arrays .. + DOUBLE PRECISION Z(1) +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DHSEQR, DLACPY, MA02AD, TB01ID, + $ TB01ZD, TB04BX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN +C .. +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + INFO = 0 + WITHD = LSAME( JOBD, 'D' ) + IF( .NOT.WITHD .AND. .NOT.LSAME( JOBD, 'Z' ) ) THEN + INFO = -1 + ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR. + $ LSAME( EQUIL, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( NPZ.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.P ) ) THEN + INFO = -14 + ELSE IF( LDNZ.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( LDNP.LT.MAX( 1, P ) ) THEN + INFO = -18 + ELSE IF( LDGAIN.LT.MAX( 1, P ) ) THEN + INFO = -24 + ELSE IF( LDWORK.LT.MAX( 1, N*( N + P ) + + $ MAX( N + MAX( N, P ), N*( 2*N + 3 ) ) ) + $ ) THEN + INFO = -28 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TB04CD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + DIJ = ZERO + IF( MIN( N, P, M ).EQ.0 ) THEN + IF( MIN( P, M ).GT.0 ) THEN +C + DO 20 J = 1, M +C + DO 10 I = 1, P + NZ(I,J) = 0 + NP(I,J) = 0 + IF ( WITHD ) + $ DIJ = D(I,J) + GAINS(I,J) = DIJ + 10 CONTINUE +C + 20 CONTINUE +C + END IF + DWORK(1) = ONE + RETURN + END IF +C +C Prepare the computation of the default tolerance. +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) THEN + EPSN = DBLE( N )*DLAMCH( 'Epsilon' ) + ANORM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK ) + END IF +C +C Initializations. +C + IA = 1 + IC = IA + N*N + ITAU = IC + P*N + JWORK = ITAU + N + IAC = ITAU +C + K = 1 +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance.) +C + IF( LSAME( EQUIL, 'S' ) ) THEN +C +C Scale simultaneously the matrices A, B and C: +C A <- inv(S)*A*S, B <- inv(S)*B and C <- C*S, where S is a +C diagonal scaling matrix. +C Workspace: need N. +C + MAXRED = C100 + CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC, + $ DWORK, IERR ) + END IF +C +C Compute the transfer function matrix of the system (A,B,C,D), +C in the pole-zero-gain form. +C + DO 80 J = 1, M +C +C Save A and C. +C Workspace: need W1 = N*(N+P). +C + CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), N ) + CALL DLACPY( 'Full', P, N, C, LDC, DWORK(IC), P ) +C +C Remove the uncontrollable part of the system (A,B(J),C). +C Workspace: need W1+N+MAX(N,P); +C prefer larger. +C + CALL TB01ZD( 'No Z', N, P, DWORK(IA), N, B(1,J), DWORK(IC), P, + $ NCONT, Z, 1, DWORK(ITAU), TOL, DWORK(JWORK), + $ LDWORK-JWORK+1, IERR ) + IF ( J.EQ.1 ) + $ WRKOPT = INT( DWORK(JWORK) ) + JWORK - 1 +C + IB = IAC + NCONT*NCONT + ICC = IB + NCONT + ITAU1 = ICC + NCONT + JWK = ITAU1 + NCONT + IAS = ITAU1 + JWORK1 = IAS + NCONT*NCONT +C + DO 70 I = 1, P + IF ( NCONT.GT.0 ) THEN + IF ( WITHD ) + $ DIJ = D(I,J) +C +C Form the matrices of the state-space representation of +C the dual system for the controllable part. +C Workspace: need W2 = W1+N*(N+2). +C + CALL MA02AD( 'Full', NCONT, NCONT, DWORK(IA), N, + $ DWORK(IAC), NCONT ) + CALL DCOPY( NCONT, B(1,J), 1, DWORK(IB), 1 ) + CALL DCOPY( NCONT, DWORK(IC+I-1), P, DWORK(ICC), 1 ) +C +C Remove the unobservable part of the system (A,B(J),C(I)). +C Workspace: need W2+2*N; +C prefer larger. +C + CALL TB01ZD( 'No Z', NCONT, 1, DWORK(IAC), NCONT, + $ DWORK(ICC), DWORK(IB), 1, IP, Z, 1, + $ DWORK(ITAU1), TOL, DWORK(JWK), LDWORK-JWK+1, + $ IERR ) + IF ( I.EQ.1 ) + $ WRKOPT = MAX( WRKOPT, INT( DWORK(JWK) ) + JWK - 1 ) +C + IF ( IP.GT.0 ) THEN +C +C Save the state matrix of the minimal part. +C Workspace: need W3 = W2+N*N. +C + CALL DLACPY( 'Full', IP, IP, DWORK(IAC), NCONT, + $ DWORK(IAS), IP ) +C +C Compute the poles of the transfer function. +C Workspace: need W3+N; +C prefer larger. +C + CALL DHSEQR( 'Eigenvalues', 'No vectors', IP, 1, IP, + $ DWORK(IAC), NCONT, POLESR(K), POLESI(K), + $ Z, 1, DWORK(JWORK1), LDWORK-JWORK1+1, + $ IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 2 + RETURN + END IF + WRKOPT = MAX( WRKOPT, + $ INT( DWORK(JWORK1) ) + JWORK1 - 1 ) +C +C Compute the zeros of the transfer function. +C + IPM1 = IP - 1 + DIJNZ = WITHD .AND. DIJ.NE.ZERO + FNDEIG = DIJNZ .OR. IPM1.GT.0 + IF ( .NOT.FNDEIG ) THEN + IZ = 0 + ELSE IF ( DIJNZ ) THEN +C +C Add the contribution due to D(i,j). +C Note that the matrix whose eigenvalues have to +C be computed remains in an upper Hessenberg form. +C + IZ = IP + CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS), IP, + $ DWORK(IAC), NCONT ) + CALL DAXPY( IZ, -DWORK(ICC)/DIJ, DWORK(IB), 1, + $ DWORK(IAC), NCONT ) + ELSE + IF( TOL.LE.ZERO ) + $ TOLDEF = EPSN*MAX( ANORM, + $ DLANGE( 'Frobenius', IP, 1, + $ DWORK(IB), 1, DWORK ) + $ ) +C + DO 30 IM = 1, IPM1 + IF ( ABS( DWORK(IB+IM-1) ).GT.TOLDEF ) GO TO 40 + 30 CONTINUE +C + IZ = 0 + GO TO 50 +C + 40 CONTINUE +C +C Restore (part of) the saved state matrix. +C + IZ = IP - IM + CALL DLACPY( 'Full', IZ, IZ, DWORK(IAS+IM*(IP+1)), + $ IP, DWORK(IAC), NCONT ) +C +C Apply the output injection. +C + CALL DAXPY( IZ, -DWORK(IAS+IM*(IP+1)-IP)/ + $ DWORK(IB+IM-1), DWORK(IB+IM), 1, + $ DWORK(IAC), NCONT ) + END IF +C + IF ( FNDEIG ) THEN +C +C Find the zeros. +C Workspace: need W3+N; +C prefer larger. +C + CALL DHSEQR( 'Eigenvalues', 'No vectors', IZ, 1, + $ IZ, DWORK(IAC), NCONT, ZEROSR(K), + $ ZEROSI(K), Z, 1, DWORK(JWORK1), + $ LDWORK-JWORK1+1, IERR ) + IF ( IERR.NE.0 ) THEN + INFO = 1 + RETURN + END IF + END IF +C +C Compute the gain. +C + 50 CONTINUE + IF ( DIJNZ ) THEN + GAINS(I,J) = DIJ + ELSE + CALL TB04BX( IP, IZ, DWORK(IAS), IP, DWORK(ICC), + $ DWORK(IB), DIJ, POLESR(K), POLESI(K), + $ ZEROSR(K), ZEROSI(K), GAINS(I,J), + $ IWORK ) + END IF + NZ(I,J) = IZ + NP(I,J) = IP + ELSE +C +C Null element. +C + NZ(I,J) = 0 + NP(I,J) = 0 + END IF +C + ELSE +C +C Null element. +C + NZ(I,J) = 0 + NP(I,J) = 0 + END IF +C + K = K + NPZ + 70 CONTINUE +C + 80 CONTINUE +C + RETURN +C *** Last line of TB04CD *** + END diff --git a/mex/sources/libslicot/TB05AD.f b/mex/sources/libslicot/TB05AD.f new file mode 100644 index 000000000..c7b93e918 --- /dev/null +++ b/mex/sources/libslicot/TB05AD.f @@ -0,0 +1,545 @@ + SUBROUTINE TB05AD( BALEIG, INITA, N, M, P, FREQ, A, LDA, B, LDB, + $ C, LDC, RCOND, G, LDG, EVRE, EVIM, HINVB, + $ LDHINV, IWORK, DWORK, LDWORK, ZWORK, LZWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the complex frequency response matrix (transfer matrix) +C G(freq) of the state-space representation (A,B,C) given by +C -1 +C G(freq) = C * ((freq*I - A) ) * B +C +C where A, B and C are real N-by-N, N-by-M and P-by-N matrices +C respectively and freq is a complex scalar. +C +C ARGUMENTS +C +C Mode Parameters +C +C BALEIG CHARACTER*1 +C Determines whether the user wishes to balance matrix A +C and/or compute its eigenvalues and/or estimate the +C condition number of the problem as follows: +C = 'N': The matrix A should not be balanced and neither +C the eigenvalues of A nor the condition number +C estimate of the problem are to be calculated; +C = 'C': The matrix A should not be balanced and only an +C estimate of the condition number of the problem +C is to be calculated; +C = 'B' or 'E' and INITA = 'G': The matrix A is to be +C balanced and its eigenvalues calculated; +C = 'A' and INITA = 'G': The matrix A is to be balanced, +C and its eigenvalues and an estimate of the +C condition number of the problem are to be +C calculated. +C +C INITA CHARACTER*1 +C Specifies whether or not the matrix A is already in upper +C Hessenberg form as follows: +C = 'G': The matrix A is a general matrix; +C = 'H': The matrix A is in upper Hessenberg form and +C neither balancing nor the eigenvalues of A are +C required. +C INITA must be set to 'G' for the first call to the +C routine, unless the matrix A is already in upper +C Hessenberg form and neither balancing nor the eigenvalues +C of A are required. Thereafter, it must be set to 'H' for +C all subsequent calls. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The number of states, i.e. the order of the state +C transition matrix A. N >= 0. +C +C M (input) INTEGER +C The number of inputs, i.e. the number of columns in the +C matrix B. M >= 0. +C +C P (input) INTEGER +C The number of outputs, i.e. the number of rows in the +C matrix C. P >= 0. +C +C FREQ (input) COMPLEX*16 +C The frequency freq at which the frequency response matrix +C (transfer matrix) is to be evaluated. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state transition matrix A. +C If INITA = 'G', then, on exit, the leading N-by-N part of +C this array contains an upper Hessenberg matrix similar to +C (via an orthogonal matrix consisting of a sequence of +C Householder transformations) the original state transition +C matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix B. +C If INITA = 'G', then, on exit, the leading N-by-M part of +C this array contains the product of the transpose of the +C orthogonal transformation matrix used to reduce A to upper +C Hessenberg form and the original input/state matrix B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C If INITA = 'G', then, on exit, the leading P-by-N part of +C this array contains the product of the original output/ +C state matrix C and the orthogonal transformation matrix +C used to reduce A to upper Hessenberg form. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C RCOND (output) DOUBLE PRECISION +C If BALEIG = 'C' or BALEIG = 'A', then RCOND contains an +C estimate of the reciprocal of the condition number of +C matrix H with respect to inversion (see METHOD). +C +C G (output) COMPLEX*16 array, dimension (LDG,M) +C The leading P-by-M part of this array contains the +C frequency response matrix G(freq). +C +C LDG INTEGER +C The leading dimension of array G. LDG >= MAX(1,P). +C +C EVRE, (output) DOUBLE PRECISION arrays, dimension (N) +C EVIM If INITA = 'G' and BALEIG = 'B' or 'E' or BALEIG = 'A', +C then these arrays contain the real and imaginary parts, +C respectively, of the eigenvalues of the matrix A. +C Otherwise, these arrays are not referenced. +C +C HINVB (output) COMPLEX*16 array, dimension (LDHINV,M) +C The leading N-by-M part of this array contains the +C -1 +C product H B. +C +C LDHINV INTEGER +C The leading dimension of array HINVB. LDHINV >= MAX(1,N). +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N - 1 + MAX(N,M,P)), +C if INITA = 'G' and BALEIG = 'N', or 'B', or 'E'; +C LDWORK >= MAX(1, N + MAX(N,M-1,P-1)), +C if INITA = 'G' and BALEIG = 'C', or 'A'; +C LDWORK >= MAX(1, 2*N), +C if INITA = 'H' and BALEIG = 'C', or 'A'; +C LDWORK >= 1, otherwise. +C For optimum performance when INITA = 'G' LDWORK should be +C larger. +C +C ZWORK COMPLEX*16 array, dimension (LZWORK) +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX(1,N*N+2*N), if BALEIG = 'C', or 'A'; +C LZWORK >= MAX(1,N*N), otherwise. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if more than 30*N iterations are required to +C isolate all the eigenvalues of the matrix A; the +C computations are continued; +C = 2: if either FREQ is too near to an eigenvalue of the +C matrix A, or RCOND is less than EPS, where EPS is +C the machine precision (see LAPACK Library routine +C DLAMCH). +C +C METHOD +C +C The matrix A is first balanced (if BALEIG = 'B' or 'E', or +C BALEIG = 'A') and then reduced to upper Hessenberg form; the same +C transformations are applied to the matrix B and the matrix C. +C The complex Hessenberg matrix H = (freq*I - A) is then used +C -1 +C to solve for C * H * B. +C +C Depending on the input values of parameters BALEIG and INITA, +C the eigenvalues of matrix A and the condition number of +C matrix H with respect to inversion are also calculated. +C +C REFERENCES +C +C [1] Laub, A.J. +C Efficient Calculation of Frequency Response Matrices from +C State-Space Models. +C ACM TOMS, 12, pp. 26-33, 1986. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TB01FD by A.J.Laub, University of +C Southern California, Los Angeles, CA 90089, United States of +C America, June 1982. +C +C REVISIONS +C +C V. Sima, February 22, 1998 (changed the name of TB01RD). +C V. Sima, February 12, 1999, August 7, 2003. +C A. Markovski, Technical University of Sofia, September 30, 2003. +C V. Sima, October 1, 2003. +C +C KEYWORDS +C +C Frequency response, Hessenberg form, matrix algebra, input output +C description, multivariable system, orthogonal transformation, +C similarity transformation, state-space representation, transfer +C matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D0, 0.0D0 ) ) +C .. Scalar Arguments .. + CHARACTER BALEIG, INITA + INTEGER INFO, LDA, LDB, LDC, LDG, LDHINV, LDWORK, + $ LZWORK, M, N, P + DOUBLE PRECISION RCOND + COMPLEX*16 FREQ +C .. Array Arguments .. + INTEGER IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), EVIM(*), + $ EVRE(*) + COMPLEX*16 ZWORK(*), G(LDG,*), HINVB(LDHINV,*) +C .. Local Scalars .. + CHARACTER BALANC + LOGICAL LBALBA, LBALEA, LBALEB, LBALEC, LINITA + INTEGER I, IGH, IJ, ITAU, J, JJ, JP, JWORK, K, LOW, + $ WRKOPT + DOUBLE PRECISION HNORM, T +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DASUM, DLAMCH + EXTERNAL DASUM, DLAMCH, LSAME +C .. External Subroutines .. + EXTERNAL DGEBAL, DGEHRD, DHSEQR, DORMHR, DSCAL, DSWAP, + $ MB02RZ, MB02SZ, MB02TZ, XERBLA, ZLASET +C .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, INT, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LBALEC = LSAME( BALEIG, 'C' ) + LBALEB = LSAME( BALEIG, 'B' ) .OR. LSAME( BALEIG, 'E' ) + LBALEA = LSAME( BALEIG, 'A' ) + LBALBA = LBALEB.OR.LBALEA + LINITA = LSAME( INITA, 'G' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LBALEC .AND. .NOT.LBALBA .AND. + $ .NOT.LSAME( BALEIG, 'N' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LINITA .AND. .NOT.LSAME( INITA, 'H' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDG.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( LDHINV.LT.MAX( 1, N ) ) THEN + INFO = -19 + ELSE IF( ( LINITA .AND. .NOT.LBALEC .AND. .NOT.LBALEA .AND. + $ LDWORK.LT.N - 1 + MAX( N, M, P ) ) .OR. + $ ( LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. + $ LDWORK.LT.N + MAX( N, M-1, P-1 ) ) .OR. + $ ( .NOT.LINITA .AND. ( LBALEC .OR. LBALEA ) .AND. + $ LDWORK.LT.2*N ) .OR. ( LDWORK.LT.1 ) ) THEN + INFO = -22 + ELSE IF( ( ( LBALEC .OR. LBALEA ) .AND. LZWORK.LT.N*( N + 2 ) ) + $ .OR. ( LZWORK.LT.MAX( 1, N*N ) ) ) THEN + INFO = -24 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return +C + CALL XERBLA( 'TB05AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( N.EQ.0 ) THEN + IF ( MIN( M, P ).GT.0 ) + $ CALL ZLASET( 'Full', P, M, CZERO, CZERO, G, LDG ) + RCOND = ONE + DWORK(1) = ONE + RETURN + END IF +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + WRKOPT = 1 +C + IF ( LINITA ) THEN + BALANC = 'N' + IF ( LBALBA ) BALANC = 'B' +C +C Workspace: need N. +C + CALL DGEBAL( BALANC, N, A, LDA, LOW, IGH, DWORK, INFO ) + IF ( LBALBA ) THEN +C +C Adjust B and C matrices based on information in the +C vector DWORK which describes the balancing of A and is +C defined in the subroutine DGEBAL. +C + DO 10 J = 1, N + JJ = J + IF ( JJ.LT.LOW .OR. JJ.GT.IGH ) THEN + IF ( JJ.LT.LOW ) JJ = LOW - JJ + JP = DWORK(JJ) + IF ( JP.NE.JJ ) THEN +C +C Permute rows of B. +C + IF ( M.GT.0 ) + $ CALL DSWAP( M, B(JJ,1), LDB, B(JP,1), LDB ) +C +C Permute columns of C. +C + IF ( P.GT.0 ) + $ CALL DSWAP( P, C(1,JJ), 1, C(1,JP), 1 ) + END IF + END IF + 10 CONTINUE +C + IF ( IGH.NE.LOW ) THEN +C + DO 20 J = LOW, IGH + T = DWORK(J) +C +C Scale rows of permuted B. +C + IF ( M.GT.0 ) + $ CALL DSCAL( M, ONE/T, B(J,1), LDB ) +C +C Scale columns of permuted C. +C + IF ( P.GT.0 ) + $ CALL DSCAL( P, T, C(1,J), 1 ) + 20 CONTINUE +C + END IF + END IF +C +C Reduce A to Hessenberg form by orthogonal similarities and +C accumulate the orthogonal transformations into B and C. +C Workspace: need 2*N - 1; prefer N - 1 + N*NB. +C + ITAU = 1 + JWORK = ITAU + N - 1 + CALL DGEHRD( N, LOW, IGH, A, LDA, DWORK(ITAU), DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need N - 1 + M; prefer N - 1 + M*NB. +C + CALL DORMHR( 'Left', 'Transpose', N, M, LOW, IGH, A, LDA, + $ DWORK(ITAU), B, LDB, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) +C +C Workspace: need N - 1 + P; prefer N - 1 + P*NB. +C + CALL DORMHR( 'Right', 'No transpose', P, N, LOW, IGH, A, LDA, + $ DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + IF ( LBALBA ) THEN +C +C Temporarily store Hessenberg form of A in array ZWORK. +C + IJ = 0 + DO 40 J = 1, N +C + DO 30 I = 1, N + IJ = IJ + 1 + ZWORK(IJ) = DCMPLX( A(I,J), ZERO ) + 30 CONTINUE +C + 40 CONTINUE +C +C Compute the eigenvalues of A if that option is requested. +C Workspace: need N. +C + CALL DHSEQR( 'Eigenvalues', 'No Schur', N, LOW, IGH, A, LDA, + $ EVRE, EVIM, DWORK, 1, DWORK, LDWORK, INFO ) +C +C Restore upper Hessenberg form of A. +C + IJ = 0 + DO 60 J = 1, N +C + DO 50 I = 1, N + IJ = IJ + 1 + A(I,J) = DBLE( ZWORK(IJ) ) + 50 CONTINUE +C + 60 CONTINUE +C + IF ( INFO.GT.0 ) THEN +C +C DHSEQR could not evaluate the eigenvalues of A. +C + INFO = 1 + END IF + END IF + END IF +C +C Update H := (FREQ * I) - A with appropriate value of FREQ. +C + IJ = 0 + JJ = 1 + DO 80 J = 1, N +C + DO 70 I = 1, N + IJ = IJ + 1 + ZWORK(IJ) = -DCMPLX( A(I,J), ZERO ) + 70 CONTINUE +C + ZWORK(JJ) = FREQ + ZWORK(JJ) + JJ = JJ + N + 1 + 80 CONTINUE +C + IF ( LBALEC .OR. LBALEA ) THEN +C +C Efficiently compute the 1-norm of the matrix for condition +C estimation. +C + HNORM = ZERO + JJ = 1 +C + DO 90 J = 1, N + T = ABS( ZWORK(JJ) ) + DASUM( J-1, A(1,J), 1 ) + IF ( J.LT.N ) T = T + ABS( A(J+1,J) ) + HNORM = MAX( HNORM, T ) + JJ = JJ + N + 1 + 90 CONTINUE +C + END IF +C +C Factor the complex Hessenberg matrix. +C + CALL MB02SZ( N, ZWORK, N, IWORK, INFO ) + IF ( INFO.NE.0 ) INFO = 2 +C + IF ( LBALEC .OR. LBALEA ) THEN +C +C Estimate the condition of the matrix. +C +C Workspace: need 2*N. +C + CALL MB02TZ( '1-norm', N, HNORM, ZWORK, N, IWORK, RCOND, DWORK, + $ ZWORK(N*N+1), INFO ) + WRKOPT = MAX( WRKOPT, 2*N ) + IF ( RCOND.LT.DLAMCH( 'Epsilon' ) ) INFO = 2 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return: Linear system is numerically or exactly singular. +C + RETURN + END IF +C +C Compute (H-INVERSE)*B. +C + DO 110 J = 1, M +C + DO 100 I = 1, N + HINVB(I,J) = DCMPLX( B(I,J), ZERO ) + 100 CONTINUE +C + 110 CONTINUE +C + CALL MB02RZ( 'No transpose', N, M, ZWORK, N, IWORK, HINVB, LDHINV, + $ INFO ) +C +C Compute C*(H-INVERSE)*B. +C + DO 150 J = 1, M +C + DO 120 I = 1, P + G(I,J) = CZERO + 120 CONTINUE +C + DO 140 K = 1, N +C + DO 130 I = 1, P + G(I,J) = G(I,J) + DCMPLX( C(I,K), ZERO )*HINVB(K,J) + 130 CONTINUE +C + 140 CONTINUE +C + 150 CONTINUE +C +C G now contains the desired frequency response matrix. +C Set the optimal workspace. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TB05AD *** + END diff --git a/mex/sources/libslicot/TC01OD.f b/mex/sources/libslicot/TC01OD.f new file mode 100644 index 000000000..3e7bd25ad --- /dev/null +++ b/mex/sources/libslicot/TC01OD.f @@ -0,0 +1,236 @@ + SUBROUTINE TC01OD( LERI, M, P, INDLIM, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find the dual right (left) polynomial matrix representation of +C a given left (right) polynomial matrix representation, where the +C right and left polynomial matrix representations are of the form +C Q(s)*inv(P(s)) and inv(P(s))*Q(s) respectively. +C +C ARGUMENTS +C +C Mode Parameters +C +C LERI CHARACTER*1 +C Indicates whether a left or right matrix fraction is input +C as follows: +C = 'L': A left matrix fraction is input; +C = 'R': A right matrix fraction is input. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C INDLIM (input) INTEGER +C The highest value of K for which PCOEFF(.,.,K) and +C QCOEFF(.,.,K) are to be transposed. +C K = kpcoef + 1, where kpcoef is the maximum degree of the +C polynomials in P(s). INDLIM >= 1. +C +C PCOEFF (input/output) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,INDLIM) +C If LERI = 'L' then porm = P, otherwise porm = M. +C On entry, the leading porm-by-porm-by-INDLIM part of this +C array must contain the coefficients of the denominator +C matrix P(s). +C PCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of +C polynomial (I,J) of P(s), where K = 1,2,...,INDLIM. +C On exit, the leading porm-by-porm-by-INDLIM part of this +C array contains the coefficients of the denominator matrix +C P'(s) of the dual system. +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P) if LERI = 'L', +C LDPCO1 >= MAX(1,M) if LERI = 'R'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P) if LERI = 'L', +C LDPCO2 >= MAX(1,M) if LERI = 'R'. +C +C QCOEFF (input/output) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,INDLIM) +C On entry, the leading P-by-M-by-INDLIM part of this array +C must contain the coefficients of the numerator matrix +C Q(s). +C QCOEFF(I,J,K) is the coefficient in s**(INDLIM-K) of +C polynomial (I,J) of Q(s), where K = 1,2,...,INDLIM. +C On exit, the leading M-by-P-by-INDLIM part of the array +C contains the coefficients of the numerator matrix Q'(s) +C of the dual system. +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C LDQCO1 >= MAX(1,M,P). +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C LDQCO2 >= MAX(1,M,P). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C If the given M-input/P-output left (right) polynomial matrix +C representation has numerator matrix Q(s) and denominator matrix +C P(s), its dual P-input/M-output right (left) polynomial matrix +C representation simply has numerator matrix Q'(s) and denominator +C matrix P'(s). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TC01CD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER LERI + INTEGER INFO, INDLIM, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, + $ P +C .. Array Arguments .. + DOUBLE PRECISION PCOEFF(LDPCO1,LDPCO2,*), QCOEFF(LDQCO1,LDQCO2,*) +C .. Local Scalars .. + LOGICAL LLERI + INTEGER J, K, MINMP, MPLIM, PORM +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LLERI = LSAME( LERI, 'L' ) + MPLIM = MAX( M, P ) + MINMP = MIN( M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( INDLIM.LT.1 ) THEN + INFO = -4 + ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN + INFO = -6 + ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF( LDQCO1.LT.MAX( 1, MPLIM ) ) THEN + INFO = -9 + ELSE IF( LDQCO2.LT.MAX( 1, MPLIM ) ) THEN + INFO = -10 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TC01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 .OR. P.EQ.0 ) + $ RETURN +C + IF ( MPLIM.NE.1 ) THEN +C +C Non-scalar system: transpose numerator matrix Q(s). +C + DO 20 K = 1, INDLIM +C + DO 10 J = 1, MPLIM + IF ( J.LT.MINMP ) THEN + CALL DSWAP( MINMP-J, QCOEFF(J+1,J,K), 1, + $ QCOEFF(J,J+1,K), LDQCO1 ) + ELSE IF ( J.GT.P ) THEN + CALL DCOPY( P, QCOEFF(1,J,K), 1, QCOEFF(J,1,K), + $ LDQCO1 ) + ELSE IF ( J.GT.M ) THEN + CALL DCOPY( M, QCOEFF(J,1,K), LDQCO1, QCOEFF(1,J,K), + $ 1 ) + END IF + 10 CONTINUE +C + 20 CONTINUE +C +C Find dimension of denominator matrix P(s): M (P) for +C right (left) polynomial matrix representation. +C + PORM = M + IF ( LLERI ) PORM = P + IF ( PORM.NE.1 ) THEN +C +C Non-scalar P(s): transpose it. +C + DO 40 K = 1, INDLIM +C + DO 30 J = 1, PORM - 1 + CALL DSWAP( PORM-J, PCOEFF(J+1,J,K), 1, + $ PCOEFF(J,J+1,K), LDPCO1 ) + 30 CONTINUE +C + 40 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of TC01OD *** + END diff --git a/mex/sources/libslicot/TC04AD.f b/mex/sources/libslicot/TC04AD.f new file mode 100644 index 000000000..d0ce99d13 --- /dev/null +++ b/mex/sources/libslicot/TC04AD.f @@ -0,0 +1,483 @@ + SUBROUTINE TC04AD( LERI, M, P, INDEX, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, N, RCOND, A, LDA, B, + $ LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a state-space representation (A,B,C,D) with the same +C transfer matrix T(s) as that of a given left or right polynomial +C matrix representation, i.e. +C +C C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)). +C +C ARGUMENTS +C +C Mode Parameters +C +C LERI CHARACTER*1 +C Indicates whether a left polynomial matrix representation +C or a right polynomial matrix representation is input as +C follows: +C = 'L': A left matrix fraction is input; +C = 'R': A right matrix fraction is input. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C INDEX (input) INTEGER array, dimension (MAX(M,P)) +C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the +C maximum degree of the polynomials in the I-th row of the +C denominator matrix P(s) of the given left polynomial +C matrix representation. +C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the +C maximum degree of the polynomials in the I-th column of +C the denominator matrix P(s) of the given right polynomial +C matrix representation. +C +C PCOEFF (input) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. +C If LERI = 'L' then porm = P, otherwise porm = M. +C The leading porm-by-porm-by-kpcoef part of this array must +C contain the coefficients of the denominator matrix P(s). +C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if +C LERI = 'L' then iorj = I, otherwise iorj = J. +C Thus for LERI = 'L', P(s) = +C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). +C If LERI = 'R', PCOEFF is modified by the routine but +C restored on exit. +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P) if LERI = 'L', +C LDPCO1 >= MAX(1,M) if LERI = 'R'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P) if LERI = 'L', +C LDPCO2 >= MAX(1,M) if LERI = 'R'. +C +C QCOEFF (input) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,kpcoef) +C If LERI = 'L' then porp = M, otherwise porp = P. +C The leading porm-by-porp-by-kpcoef part of this array must +C contain the coefficients of the numerator matrix Q(s). +C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C If LERI = 'R', QCOEFF is modified by the routine but +C restored on exit. +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C LDQCO1 >= MAX(1,P) if LERI = 'L', +C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C LDQCO2 >= MAX(1,M) if LERI = 'L', +C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. +C +C N (output) INTEGER +C The order of the resulting state-space representation. +C porm +C That is, N = SUM INDEX(I). +C I=1 +C +C RCOND (output) DOUBLE PRECISION +C The estimated reciprocal of the condition number of the +C leading row (if LERI = 'L') or the leading column (if +C LERI = 'R') coefficient matrix of P(s). +C If RCOND is nearly zero, P(s) is nearly row or column +C non-proper. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array contains the state +C dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) +C The leading N-by-M part of this array contains the +C input/state matrix B; the remainder of the leading +C N-by-MAX(M,P) part is used as internal workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array contains the +C state/output matrix C; the remainder of the leading +C MAX(M,P)-by-N part is used as internal workspace. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) +C The leading P-by-M part of this array contains the direct +C transmission matrix D; the remainder of the leading +C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C Workspace +C +C IWORK INTEGER array, dimension (2*MAX(M,P)) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,MAX(M,P)*(MAX(M,P)+4)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if P(s) is not row (if LERI = 'L') or column +C (if LERI = 'R') proper. Consequently, no state-space +C representation is calculated. +C +C METHOD +C +C The method for a left matrix fraction will be described here; +C right matrix fractions are dealt with by obtaining the dual left +C polynomial matrix representation and constructing an equivalent +C state-space representation for this. The first step is to check +C if the denominator matrix P(s) is row proper; if it is not then +C the routine returns with the Error Indicator (INFO) set to 1. +C Otherwise, Wolovich's Observable Structure Theorem is used to +C construct a state-space representation (A,B,C,D) in observable +C companion form. The sizes of the blocks of matrix A and matrix C +C here are precisely the row degrees of P(s), while their +C 'non-trivial' columns are given easily from its coefficients. +C Similarly, the matrix D is obtained from the leading coefficients +C of P(s) and of the numerator matrix Q(s), while matrix B is given +C by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a +C polynomial matrix whose (j,k)(th) element is given by +C +C j-u(k-1)-1 +C ( s , j = u(k-1)+1,u(k-1)+2,....,u(k) +C Sbar = ( +C j,k ( 0 , otherwise +C +C k +C u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d are the +C i=1 i 1 2 M +C controllability indices. For convenience in solving this, C' and B +C are initially set up to contain the coefficients of P(s) and Q(s), +C respectively, stored by rows. +C +C REFERENCES +C +C [1] Wolovich, W.A. +C Linear Multivariate Systems, (Theorem 4.3.3). +C Springer-Verlag, 1974. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TC01BD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C February 22, 1998 (changed the name of TC01ND). +C May 12, 1998. +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER LERI + INTEGER INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, + $ LDQCO1, LDQCO2, LDWORK, M, N, P + DOUBLE PRECISION RCOND +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), + $ QCOEFF(LDQCO1,LDQCO2,*) +C .. Local Scalars .. + LOGICAL LLERI + INTEGER I, IA, IBIAS, J, JA, JC, JW, JWORK, LDW, K, + $ KPCOEF, KSTOP, MAXIND, MINDEX, MWORK, PWORK, + $ WRKOPT + DOUBLE PRECISION DWNORM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL LSAME, DLAMCH, DLANGE +C .. External Subroutines .. + EXTERNAL AB07MD, DCOPY, DGECON, DGEMM, DGETRF, DGETRI, + $ DGETRS, DLACPY, DLASET, TC01OD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C .. Executable Statements .. +C + INFO = 0 + LLERI = LSAME( LERI, 'L' ) + MINDEX = MAX( M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN + INFO = -6 + ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, MINDEX ) ) ) THEN + INFO = -9 + ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MINDEX ) ) ) THEN + INFO = -10 + END IF +C + N = 0 + IF ( INFO.EQ.0 ) THEN + IF ( LLERI ) THEN + PWORK = P + MWORK = M + ELSE + PWORK = M + MWORK = P + END IF +C + MAXIND = 0 + DO 10 I = 1, PWORK + N = N + INDEX(I) + IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) + 10 CONTINUE + KPCOEF = MAXIND + 1 + END IF +C + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDC.LT.MAX( 1, MINDEX ) ) THEN + INFO = -18 + ELSE IF( LDD.LT.MAX( 1, MINDEX ) ) THEN + INFO = -20 + ELSE IF( LDWORK.LT.MAX( 1, MINDEX*( MINDEX + 4 ) ) ) THEN + INFO = -23 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TC04AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 .OR. P.EQ.0 ) THEN + N = 0 + RCOND = ONE + DWORK(1) = ONE + RETURN + END IF +C + IF ( .NOT.LLERI ) THEN +C +C Initialization for right matrix fraction: obtain the dual +C system. +C + CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, INFO ) + END IF +C +C Store leading row coefficient matrix of P(s). +C + LDW = MAX( 1, PWORK ) + CALL DLACPY( 'Full', PWORK, PWORK, PCOEFF, LDPCO1, DWORK, LDW ) +C +C Check if P(s) is row proper: if not, exit. +C + DWNORM = DLANGE( '1-norm', PWORK, PWORK, DWORK, LDW, DWORK ) +C + CALL DGETRF( PWORK, PWORK, DWORK, LDW, IWORK, INFO ) +C +C Workspace: need PWORK*(PWORK + 4). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C + JWORK = LDW*PWORK + 1 +C + CALL DGECON( '1-norm', PWORK, DWORK, LDW, DWNORM, RCOND, + $ DWORK(JWORK), IWORK(PWORK+1), INFO ) +C + WRKOPT = MAX( 1, PWORK*(PWORK + 4) ) +C + IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN +C +C Error return: P(s) is not row proper. +C + INFO = 1 + RETURN + ELSE +C +C Calculate the order of equivalent state-space representation, +C and initialize A. +C + CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA ) +C + DWORK(JWORK) = ONE + IF ( N.GT.1 ) CALL DCOPY( N-1, DWORK(JWORK), 0, A(2,1), LDA+1 ) +C +C Find the PWORK ordered 'non-trivial' columns row by row, +C in PWORK row blocks, the I-th having INDEX(I) rows. +C + IBIAS = 2 +C + DO 50 I = 1, PWORK + KSTOP = INDEX(I) + 1 + IF ( KSTOP.NE.1 ) THEN + IBIAS = IBIAS + INDEX(I) +C +C These rows given from the lower coefficients of row I +C of P(s). +C + DO 40 K = 2, KSTOP + IA = IBIAS - K +C + DO 20 J = 1, PWORK + DWORK(JWORK+J-1) = -PCOEFF(I,J,K) + 20 CONTINUE +C + CALL DGETRS( 'Transpose', PWORK, 1, DWORK, LDW, + $ IWORK, DWORK(JWORK), LDW, INFO ) +C + JA = 0 +C + DO 30 J = 1, PWORK + IF ( INDEX(J).NE.0 ) THEN + JA = JA + INDEX(J) + A(IA,JA) = DWORK(JWORK+J-1) + END IF + 30 CONTINUE +C +C Also, set up B and C (temporarily) for use when +C finding B. +C + CALL DCOPY( MWORK, QCOEFF(I,1,K), LDQCO1, B(IA,1), + $ LDB ) + CALL DCOPY( PWORK, PCOEFF(I,1,K), LDPCO1, C(1,IA), 1 ) + 40 CONTINUE +C + END IF + 50 CONTINUE +C +C Calculate D from the leading coefficients of P and Q. +C + CALL DLACPY( 'Full', PWORK, MWORK, QCOEFF, LDQCO1, D, LDD ) +C + CALL DGETRS( 'No transpose', PWORK, MWORK, DWORK, LDW, IWORK, + $ D, LDD, INFO ) +C +C For B and C as set up above, desired B = B - (C' * D). +C + CALL DGEMM( 'Transpose', 'No transpose', N, MWORK, PWORK, -ONE, + $ C, LDC, D, LDD, ONE, B, LDB ) +C +C Finally, calculate C: zero, apart from ... +C + CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) +C +C PWORK ordered 'non-trivial' columns, equal to those +C of inv(DWORK). +C +C Workspace: need PWORK*(PWORK + 1); +C prefer PWORK*PWORK + PWORK*NB. +C + CALL DGETRI( PWORK, DWORK, LDW, IWORK, DWORK(JWORK), + $ LDWORK-JWORK+1, INFO ) +C + WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 ) + JC = 0 + JW = 1 +C + DO 60 J = 1, PWORK + IF ( INDEX(J).NE.0 ) THEN + JC = JC + INDEX(J) + CALL DCOPY( PWORK, DWORK(JW), 1, C(1,JC), 1 ) + END IF + JW = JW + LDW + 60 CONTINUE +C + END IF +C +C For right matrix fraction, return to original (dual of dual) +C system. +C + IF ( .NOT.LLERI ) THEN + CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO ) +C +C Also, obtain dual of state-space representation. +C + CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, + $ LDD, INFO ) + END IF +C +C Set optimal workspace dimension. +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TC04AD *** + END diff --git a/mex/sources/libslicot/TC05AD.f b/mex/sources/libslicot/TC05AD.f new file mode 100644 index 000000000..fc9f65ab0 --- /dev/null +++ b/mex/sources/libslicot/TC05AD.f @@ -0,0 +1,403 @@ + SUBROUTINE TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR, + $ LDCFRE, IWORK, DWORK, ZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To evaluate the transfer matrix T(s) of a left polynomial matrix +C representation [T(s) = inv(P(s))*Q(s)] or a right polynomial +C matrix representation [T(s) = Q(s)*inv(P(s))] at any specified +C complex frequency s = SVAL. +C +C This routine will calculate the standard frequency response +C matrix at frequency omega if SVAL is supplied as (0.0,omega). +C +C ARGUMENTS +C +C Mode Parameters +C +C LERI CHARACTER*1 +C Indicates whether a left polynomial matrix representation +C or a right polynomial matrix representation is to be used +C to evaluate the transfer matrix as follows: +C = 'L': A left matrix fraction is input; +C = 'R': A right matrix fraction is input. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C SVAL (input) COMPLEX*16 +C The frequency at which the transfer matrix or the +C frequency respose matrix is to be evaluated. +C For a standard frequency response set the real part +C of SVAL to zero. +C +C INDEX (input) INTEGER array, dimension (MAX(M,P)) +C If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the +C maximum degree of the polynomials in the I-th row of the +C denominator matrix P(s) of the given left polynomial +C matrix representation. +C If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the +C maximum degree of the polynomials in the I-th column of +C the denominator matrix P(s) of the given right polynomial +C matrix representation. +C +C PCOEFF (input) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1. +C If LERI = 'L' then porm = P, otherwise porm = M. +C The leading porm-by-porm-by-kpcoef part of this array must +C contain the coefficients of the denominator matrix P(s). +C PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if +C LERI = 'L' then iorj = I, otherwise iorj = J. +C Thus for LERI = 'L', P(s) = +C diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). +C If LERI = 'R', PCOEFF is modified by the routine but +C restored on exit. +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P) if LERI = 'L', +C LDPCO1 >= MAX(1,M) if LERI = 'R'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P) if LERI = 'L', +C LDPCO2 >= MAX(1,M) if LERI = 'R'. +C +C QCOEFF (input) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,kpcoef) +C If LERI = 'L' then porp = M, otherwise porp = P. +C The leading porm-by-porp-by-kpcoef part of this array must +C contain the coefficients of the numerator matrix Q(s). +C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C If LERI = 'R', QCOEFF is modified by the routine but +C restored on exit. +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C LDQCO1 >= MAX(1,P) if LERI = 'L', +C LDQCO1 >= MAX(1,M,P) if LERI = 'R'. +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C LDQCO2 >= MAX(1,M) if LERI = 'L', +C LDQCO2 >= MAX(1,M,P) if LERI = 'R'. +C +C RCOND (output) DOUBLE PRECISION +C The estimated reciprocal of the condition number of the +C denominator matrix P(SVAL). +C If RCOND is nearly zero, SVAL is approximately a system +C pole. +C +C CFREQR (output) COMPLEX*16 array, dimension (LDCFRE,MAX(M,P)) +C The leading porm-by-porp part of this array contains the +C frequency response matrix T(SVAL). +C +C LDCFRE INTEGER +C The leading dimension of array CFREQR. +C LDCFRE >= MAX(1,P) if LERI = 'L', +C LDCFRE >= MAX(1,M,P) if LERI = 'R'. +C +C Workspace +C +C IWORK INTEGER array, dimension (liwork) +C where liwork = P, if LERI = 'L', +C liwork = M, if LERI = 'R'. +C +C DWORK DOUBLE PRECISION array, dimension (ldwork) +C where ldwork = 2*P, if LERI = 'L', +C ldwork = 2*M, if LERI = 'R'. +C +C ZWORK COMPLEX*16 array, dimension (lzwork), +C where lzwork = P*(P+2), if LERI = 'L', +C lzwork = M*(M+2), if LERI = 'R'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if P(SVAL) is exactly or nearly singular; +C no frequency response is calculated. +C +C METHOD +C +C The method for a left matrix fraction will be described here; +C right matrix fractions are dealt with by obtaining the dual left +C fraction and calculating its frequency response (see SLICOT +C Library routine TC01OD). The first step is to calculate the +C complex value P(SVAL) of the denominator matrix P(s) at the +C desired frequency SVAL. If P(SVAL) is approximately singular, +C SVAL is approximately a pole of this system and so the frequency +C response matrix T(SVAL) is not calculated; in this case, the +C routine returns with the Error Indicator (INFO) set to 1. +C Otherwise, the complex value Q(SVAL) of the numerator matrix Q(s) +C at frequency SVAL is calculated in a similar way to P(SVAL), and +C the desired response matrix T(SVAL) = inv(P(SVAL))*Q(SVAL) is +C found by solving the corresponding system of complex linear +C equations. +C +C REFERENCES +C +C None +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TC01AD by T.W.C.Williams, Kingston +C Polytechnic, United Kingdom, March 1982. +C +C REVISIONS +C +C February 22, 1998 (changed the name of TC01MD). +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER LERI + INTEGER INFO, LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M, + $ P + DOUBLE PRECISION RCOND + COMPLEX*16 SVAL +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION DWORK(*), PCOEFF(LDPCO1,LDPCO2,*), + $ QCOEFF(LDQCO1,LDQCO2,*) + COMPLEX*16 CFREQR(LDCFRE,*), ZWORK(*) +C .. Local Scalars .. + LOGICAL LLERI + INTEGER I, IZWORK, IJ, INFO1, J, K, KPCOEF, LDZWOR, + $ MAXIND, MINMP, MPLIM, MWORK, PWORK + DOUBLE PRECISION CNORM +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL TC01OD, XERBLA, ZCOPY, ZGECON, ZGETRF, ZGETRS, + $ ZSWAP +C .. Intrinsic Functions .. + INTRINSIC DCMPLX, MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LLERI = LSAME( LERI, 'L' ) + MPLIM = MAX( M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN + INFO = -7 + ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN + INFO = -8 + ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, M, P ) ) ) THEN + INFO = -10 + ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR. + $ ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MPLIM ) ) ) THEN + INFO = -11 + ELSE IF( ( LLERI .AND. LDCFRE.LT.MAX( 1, P ) ) .OR. + $ ( .NOT.LLERI .AND. LDCFRE.LT.MAX( 1, MPLIM ) ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TC05AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( M.EQ.0 .OR. P.EQ.0 ) THEN + RCOND = ONE + RETURN + END IF +C + IF ( LLERI ) THEN +C +C Initialization for left matrix fraction. +C + PWORK = P + MWORK = M + ELSE +C +C Initialization for right matrix fraction: obtain dual system. +C + PWORK = M + MWORK = P + IF ( MPLIM.GT.1 ) + $ CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, INFO ) + END IF +C + LDZWOR = PWORK + IZWORK = LDZWOR*LDZWOR + 1 + MAXIND = 0 +C + DO 10 I = 1, PWORK + IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I) + 10 CONTINUE +C + KPCOEF = MAXIND + 1 +C +C Calculate the complex denominator matrix P(SVAL), row by row. +C + DO 50 I = 1, PWORK + IJ = I +C + DO 20 J = 1, PWORK + ZWORK(IJ) = DCMPLX( PCOEFF(I,J,1), ZERO ) + IJ = IJ + PWORK + 20 CONTINUE +C +C Possibly non-constant row: finish evaluating it. +C + DO 40 K = 2, INDEX(I) + 1 +C + IJ = I +C + DO 30 J = 1, PWORK + ZWORK(IJ) = ( SVAL*ZWORK(IJ) ) + + $ DCMPLX( PCOEFF(I,J,K), ZERO ) + IJ = IJ + PWORK + 30 CONTINUE +C + 40 CONTINUE +C + 50 CONTINUE +C +C Check if this P(SVAL) is singular: if so, don't compute T(SVAL). +C Note that DWORK is not actually referenced in ZLANGE routine. +C + CNORM = ZLANGE( '1-norm', PWORK, PWORK, ZWORK, LDZWOR, DWORK ) +C + CALL ZGETRF( PWORK, PWORK, ZWORK, LDZWOR, IWORK, INFO ) +C + IF ( INFO.GT.0 ) THEN +C +C Singular matrix. Set INFO and RCOND for error return. +C + INFO = 1 + RCOND = ZERO + ELSE +C +C Estimate the reciprocal condition of P(SVAL). +C Workspace: ZWORK: PWORK*PWORK + 2*PWORK, DWORK: 2*PWORK. +C + CALL ZGECON( '1-norm', PWORK, ZWORK, LDZWOR, CNORM, RCOND, + $ ZWORK(IZWORK), DWORK, INFO ) +C + IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN +C +C Nearly singular matrix. Set INFO for error return. +C + INFO = 1 + ELSE +C +C Calculate the complex numerator matrix Q(SVAL), row by row. +C + DO 90 I = 1, PWORK +C + DO 60 J = 1, MWORK + CFREQR(I,J) = DCMPLX( QCOEFF(I,J,1), ZERO ) + 60 CONTINUE +C +C Possibly non-constant row: finish evaluating it. +C + DO 80 K = 2, INDEX(I) + 1 +C + DO 70 J = 1, MWORK + CFREQR(I,J) = ( SVAL*CFREQR(I,J) ) + + $ DCMPLX( QCOEFF(I,J,K), ZERO ) + 70 CONTINUE +C + 80 CONTINUE +C + 90 CONTINUE +C +C Now calculate frequency response T(SVAL). +C + CALL ZGETRS( 'No transpose', PWORK, MWORK, ZWORK, LDZWOR, + $ IWORK, CFREQR, LDCFRE, INFO ) + END IF + END IF +C +C For right matrix fraction, return to original (dual of the dual) +C system. +C + IF ( ( .NOT.LLERI ) .AND. ( MPLIM.NE.1 ) ) THEN + CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO1 ) +C + IF ( INFO.EQ.0 ) THEN +C +C Also, transpose T(SVAL) here if this was successfully +C calculated. +C + MINMP = MIN( M, P ) +C + DO 100 J = 1, MPLIM + IF ( J.LT.MINMP ) THEN + CALL ZSWAP( MINMP-J, CFREQR(J+1,J), 1, CFREQR(J,J+1), + $ LDCFRE ) + ELSE IF ( J.GT.P ) THEN + CALL ZCOPY( P, CFREQR(1,J), 1, CFREQR(J,1), LDCFRE ) + ELSE IF ( J.GT.M ) THEN + CALL ZCOPY( M, CFREQR(J,1), LDCFRE, CFREQR(1,J), 1 ) + END IF + 100 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of TC05AD *** + END diff --git a/mex/sources/libslicot/TD03AD.f b/mex/sources/libslicot/TD03AD.f new file mode 100644 index 000000000..b06678a78 --- /dev/null +++ b/mex/sources/libslicot/TD03AD.f @@ -0,0 +1,581 @@ + SUBROUTINE TD03AD( ROWCOL, LERI, EQUIL, M, P, INDEXD, DCOEFF, + $ LDDCOE, UCOEFF, LDUCO1, LDUCO2, NR, A, LDA, B, + $ LDB, C, LDC, D, LDD, INDEXP, PCOEFF, LDPCO1, + $ LDPCO2, QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, + $ LDVCO2, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a relatively prime left or right polynomial matrix +C representation for a proper transfer matrix T(s) given as either +C row or column polynomial vectors over common denominator +C polynomials, possibly with uncancelled common terms. +C +C ARGUMENTS +C +C Mode Parameters +C +C ROWCOL CHARACTER*1 +C Indicates whether T(s) is to be factorized by rows or by +C columns as follows: +C = 'R': T(s) is factorized by rows; +C = 'C': T(s) is factorized by columns. +C +C LERI CHARACTER*1 +C Indicates whether a left or a right polynomial matrix +C representation is required as follows: +C = 'L': A left polynomial matrix representation +C inv(P(s))*Q(s) is required; +C = 'R': A right polynomial matrix representation +C Q(s)*inv(P(s)) is required. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to balance the triplet +C (A,B,C), before computing a minimal state-space +C representation, as follows: +C = 'S': Perform balancing (scaling); +C = 'N': Do not perform balancing. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C INDEXD (input) INTEGER array, dimension (P), if ROWCOL = 'R', or +C dimension (M), if ROWCOL = 'C'. +C The leading pormd elements of this array must contain the +C row degrees of the denominator polynomials in D(s). +C pormd = P if the transfer matrix T(s) is given as row +C polynomial vectors over denominator polynomials; +C pormd = M if the transfer matrix T(s) is given as column +C polynomial vectors over denominator polynomials. +C +C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), +C where kdcoef = MAX(INDEXD(I)) + 1. +C The leading pormd-by-kdcoef part of this array must +C contain the coefficients of each denominator polynomial. +C DCOEFF(I,K) is the coefficient in s**(INDEXD(I)-K+1) of +C the I-th denominator polynomial in D(s), where K = 1,2, +C ...,kdcoef. +C +C LDDCOE INTEGER +C The leading dimension of array DCOEFF. +C LDDCOE >= MAX(1,P), if ROWCOL = 'R'; +C LDDCOE >= MAX(1,M), if ROWCOL = 'C'. +C +C UCOEFF (input) DOUBLE PRECISION array, dimension +C (LDUCO1,LDUCO2,kdcoef) +C The leading P-by-M-by-kdcoef part of this array must +C contain the coefficients of the numerator matrix U(s); +C if ROWCOL = 'C', this array is modified internally but +C restored on exit, and the remainder of the leading +C MAX(M,P)-by-MAX(M,P)-by-kdcoef part is used as internal +C workspace. +C UCOEFF(I,J,K) is the coefficient in s**(INDEXD(iorj)-K+1) +C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; +C iorj = I if T(s) is given as row polynomial vectors over +C denominator polynomials; iorj = J if T(s) is given as +C column polynomial vectors over denominator polynomials. +C Thus for ROWCOL = 'R', U(s) = +C diag(s**INDEXD(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). +C +C LDUCO1 INTEGER +C The leading dimension of array UCOEFF. +C LDUCO1 >= MAX(1,P), if ROWCOL = 'R'; +C LDUCO1 >= MAX(1,M,P), if ROWCOL = 'C'. +C +C LDUCO2 INTEGER +C The second dimension of array UCOEFF. +C LDUCO2 >= MAX(1,M), if ROWCOL = 'R'; +C LDUCO2 >= MAX(1,M,P), if ROWCOL = 'C'. +C +C NR (output) INTEGER +C The order of the resulting minimal realization, i.e. the +C order of the state dynamics matrix A. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N), +C pormd +C where N = SUM INDEXD(I) +C I=1 +C The leading NR-by-NR part of this array contains the upper +C block Hessenberg state dynamics matrix A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) +C The leading NR-by-M part of this array contains the +C input/state matrix B; the remainder of the leading +C N-by-MAX(M,P) part is used as internal workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-NR part of this array contains the +C state/output matrix C; the remainder of the leading +C MAX(M,P)-by-N part is used as internal workspace. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C D (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P)) +C The leading P-by-M part of this array contains the direct +C transmission matrix D; the remainder of the leading +C MAX(M,P)-by-MAX(M,P) part is used as internal workspace. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,M,P). +C +C INDEXP (output) INTEGER array, dimension (P), if ROWCOL = 'R', or +C dimension (M), if ROWCOL = 'C'. +C The leading pormp elements of this array contain the +C row (column if ROWCOL = 'C') degrees of the denominator +C matrix P(s). +C pormp = P if a left polynomial matrix representation +C is requested; pormp = M if a right polynomial matrix +C representation is requested. +C These elements are ordered so that +C INDEXP(1) >= INDEXP(2) >= ... >= INDEXP(pormp). +C +C PCOEFF (output) DOUBLE PRECISION array, dimension +C (LDPCO1,LDPCO2,N+1) +C The leading pormp-by-pormp-by-kpcoef part of this array +C contains the coefficients of the denominator matrix P(s), +C where kpcoef = MAX(INDEXP(I)) + 1. +C PCOEFF(I,J,K) is the coefficient in s**(INDEXP(iorj)-K+1) +C of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; +C iorj = I if a left polynomial matrix representation is +C requested; iorj = J if a right polynomial matrix +C representation is requested. +C Thus for a left polynomial matrix representation, P(s) = +C diag(s**INDEXP(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...). +C +C LDPCO1 INTEGER +C The leading dimension of array PCOEFF. +C LDPCO1 >= MAX(1,P), if ROWCOL = 'R'; +C LDPCO1 >= MAX(1,M), if ROWCOL = 'C'. +C +C LDPCO2 INTEGER +C The second dimension of array PCOEFF. +C LDPCO2 >= MAX(1,P), if ROWCOL = 'R'; +C LDPCO2 >= MAX(1,M), if ROWCOL = 'C'. +C +C QCOEFF (output) DOUBLE PRECISION array, dimension +C (LDQCO1,LDQCO2,N+1) +C The leading pormp-by-pormd-by-kpcoef part of this array +C contains the coefficients of the numerator matrix Q(s). +C QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K). +C +C LDQCO1 INTEGER +C The leading dimension of array QCOEFF. +C If LERI = 'L', LDQCO1 >= MAX(1,PM), +C where PM = P, if ROWCOL = 'R'; +C PM = M, if ROWCOL = 'C'. +C If LERI = 'R', LDQCO1 >= MAX(1,M,P). +C +C LDQCO2 INTEGER +C The second dimension of array QCOEFF. +C If LERI = 'L', LDQCO2 >= MAX(1,MP), +C where MP = M, if ROWCOL = 'R'; +C MP = P, if ROWCOL = 'C'. +C If LERI = 'R', LDQCO2 >= MAX(1,M,P). +C +C VCOEFF (output) DOUBLE PRECISION array, dimension +C (LDVCO1,LDVCO2,N+1) +C The leading pormp-by-NR-by-kpcoef part of this array +C contains the coefficients of the intermediate matrix +C V(s) as produced by SLICOT Library routine TB03AD. +C +C LDVCO1 INTEGER +C The leading dimension of array VCOEFF. +C LDVCO1 >= MAX(1,P), if ROWCOL = 'R'; +C LDVCO1 >= MAX(1,M), if ROWCOL = 'C'. +C +C LDVCO2 INTEGER +C The second dimension of array VCOEFF. LDVCO2 >= MAX(1,N). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B, C). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance +C (determined by the SLICOT routine TB01UD) is used instead. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P), PM*(PM + 2)) +C where PM = P, if ROWCOL = 'R'; +C PM = M, if ROWCOL = 'C'. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i (i <= k = pormd), then i is the first +C integer I for which ABS( DCOEFF(I,1) ) is so small +C that the calculations would overflow (see SLICOT +C Library routine TD03AY); that is, the leading +C coefficient of a polynomial is nearly zero; no +C state-space representation or polynomial matrix +C representation is calculated; +C = k+1: if a singular matrix was encountered during the +C computation of V(s); +C = k+2: if a singular matrix was encountered during the +C computation of P(s). +C +C METHOD +C +C The method for transfer matrices factorized by rows will be +C described here; T(s) factorized by columns is dealt with by +C operating on the dual T'(s). The description for T(s) is actually +C the left polynomial matrix representation +C +C T(s) = inv(D(s))*U(s), +C +C where D(s) is diagonal with its (I,I)-th polynomial element of +C degree INDEXD(I). The first step is to check whether the leading +C coefficient of any polynomial element of D(s) is approximately +C zero, if so the routine returns with INFO > 0. Otherwise, +C Wolovich's Observable Structure Theorem is used to construct a +C state-space representation in observable companion form which is +C equivalent to the above polynomial matrix representation. The +C method is particularly easy here due to the diagonal form of D(s). +C This state-space representation is not necessarily controllable +C (as D(s) and U(s) are not necessarily relatively left prime), but +C it is in theory completely observable; however, its observability +C matrix may be poorly conditioned, so it is treated as a general +C state-space representation and SLICOT Library routine TB03AD is +C used to separate out a minimal realization for T(s) from it by +C means of orthogonal similarity transformations and then to +C calculate a relatively prime (left or right) polynomial matrix +C representation which is equivalent to this. +C +C REFERENCES +C +C [1] Patel, R.V. +C On Computing Matrix Fraction Descriptions and Canonical +C Forms of Linear Time-Invariant Systems. +C UMIST Control Systems Centre Report 489, 1980. +C +C [2] Wolovich, W.A. +C Linear Multivariable Systems, (Theorem 4.3.3). +C Springer-Verlag, 1974. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998. +C Supersedes Release 3.0 routine TD01ND. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, LERI, ROWCOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDPCO1, + $ LDPCO2, LDQCO1, LDQCO2, LDUCO1, LDUCO2, LDVCO1, + $ LDVCO2, LDWORK, M, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INDEXD(*), INDEXP(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DCOEFF(LDDCOE,*), DWORK(*), + $ PCOEFF(LDPCO1,LDPCO2,*), + $ QCOEFF(LDQCO1,LDQCO2,*), + $ UCOEFF(LDUCO1,LDUCO2,*), VCOEFF(LDVCO1,LDVCO2,*) +C .. Local Scalars .. + LOGICAL LEQUIL, LLERI, LROWCO + INTEGER I, IDUAL, ITEMP, J, JSTOP, K, KDCOEF, KPCOEF, + $ MAXMP, MPLIM, MWORK, N, PWORK +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, DLACPY, DSWAP, TB01XD, TB03AD, TC01OD, + $ TD03AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + LROWCO = LSAME( ROWCOL, 'R' ) + LLERI = LSAME( LERI, 'L' ) + LEQUIL = LSAME( EQUIL, 'S' ) +C +C Test the input scalar arguments. +C + MAXMP = MAX( M, P ) + MPLIM = MAX( 1, MAXMP ) + IF ( LROWCO ) THEN +C +C Initialization for T(s) given as rows over common denominators. +C + PWORK = P + MWORK = M + ELSE +C +C Initialization for T(s) given as columns over common +C denominators. +C + PWORK = M + MWORK = P + END IF +C + IF( .NOT.LROWCO .AND. .NOT.LSAME( ROWCOL, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDDCOE.LT.MAX( 1, PWORK ) ) THEN + INFO = -8 + ELSE IF( LDUCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LROWCO .AND. + $ LDUCO1.LT.MPLIM ) ) THEN + INFO = -10 + ELSE IF( LDUCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LROWCO .AND. + $ LDUCO2.LT.MPLIM ) ) THEN + INFO = -11 + END IF +C + N = 0 + IF ( INFO.EQ.0 ) THEN +C +C Calculate N, the order of the resulting state-space +C representation, and the index kdcoef. +C + KDCOEF = 0 +C + DO 10 I = 1, PWORK + KDCOEF = MAX( KDCOEF, INDEXD(I) ) + N = N + INDEXD(I) + 10 CONTINUE +C + KDCOEF = KDCOEF + 1 +C + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -16 + ELSE IF( LDC.LT.MPLIM ) THEN + INFO = -18 + ELSE IF( LDD.LT.MPLIM ) THEN + INFO = -20 + ELSE IF( LDPCO1.LT.PWORK ) THEN + INFO = -23 + ELSE IF( LDPCO2.LT.PWORK ) THEN + INFO = -24 + ELSE IF( LDQCO1.LT.MAX( 1, PWORK ) .OR. ( .NOT.LLERI .AND. + $ LDQCO1.LT.MPLIM ) ) THEN + INFO = -26 + ELSE IF( LDQCO2.LT.MAX( 1, MWORK ) .OR. ( .NOT.LLERI .AND. + $ LDQCO2.LT.MPLIM ) ) THEN + INFO = -27 + ELSE IF( LDVCO1.LT.MAX( 1, PWORK ) ) THEN + INFO = -29 + ELSE IF( LDVCO2.LT.MAX( 1, N ) ) THEN + INFO = -30 +C + ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*MAXMP ), + $ PWORK*( PWORK + 2 ) ) ) THEN + INFO = -34 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TD03AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C +C IDUAL = 1 iff precisely ROWCOL = 'C' or (exclusively) LERI = 'R', +C i.e. iff AB07MD call is required before TB03AD. +C + IDUAL = 0 + IF ( .NOT.LROWCO ) IDUAL = 1 + IF ( .NOT.LLERI ) IDUAL = IDUAL + 1 +C + IF ( .NOT.LROWCO ) THEN +C +C Initialize the remainder of the leading +C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. +C + IF ( P.LT.M ) THEN +C + DO 20 K = 1, KDCOEF + CALL DLACPY( 'Full', M-P, MPLIM, ZERO, ZERO, + $ UCOEFF(P+1,1,K), LDUCO1 ) + 20 CONTINUE +C + ELSE IF ( P.GT.M ) THEN +C + DO 30 K = 1, KDCOEF + CALL DLACPY( 'Full', MPLIM, P-M, ZERO, ZERO, + $ UCOEFF(1,M+1,K), LDUCO1 ) + 30 CONTINUE +C + END IF +C + IF ( MPLIM.NE.1 ) THEN +C +C Non-scalar T(s) factorized by columns: transpose it +C (i.e. U(s)). +C + JSTOP = MPLIM - 1 +C + DO 50 K = 1, KDCOEF +C + DO 40 J = 1, JSTOP + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, + $ UCOEFF(J,J+1,K), LDUCO1 ) + 40 CONTINUE +C + 50 CONTINUE +C + END IF + END IF +C +C Construct non-minimal state-space representation (by Wolovich's +C Structure Theorem) which has transfer matrix T(s) or T'(s) as +C appropriate, +C + CALL TD03AY( MWORK, PWORK, INDEXD, DCOEFF, LDDCOE, UCOEFF, LDUCO1, + $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) + IF ( INFO.GT.0 ) + $ RETURN +C + IF ( IDUAL.EQ.1 ) THEN +C +C and then obtain (MWORK x PWORK) dual of this system if +C appropriate. +C + CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D, + $ LDD, INFO ) + ITEMP = PWORK + PWORK = MWORK + MWORK = ITEMP + END IF +C +C Find left polynomial matrix representation (and minimal +C state-space representation en route) for the relevant state-space +C representation ... +C + CALL TB03AD( 'Left', EQUIL, N, MWORK, PWORK, A, LDA, B, LDB, C, + $ LDC, D, LDD, NR, INDEXP, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, VCOEFF, LDVCO1, LDVCO2, TOL, + $ IWORK, DWORK, LDWORK, INFO ) +C + IF ( INFO.GT.0 ) THEN + INFO = PWORK + INFO + RETURN + END IF +C + IF ( .NOT.LLERI ) THEN +C +C and, if a right polynomial matrix representation is required, +C transpose and reorder (to get a block upper Hessenberg +C matrix A). +C + K = IWORK(1) - 1 + IF ( N.GE.2 ) + $ K = K + IWORK(2) + CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, C, + $ LDC, D, LDD, INFO ) +C + KPCOEF = 0 +C + DO 60 I = 1, PWORK + KPCOEF = MAX( KPCOEF, INDEXP(I) ) + 60 CONTINUE +C + KPCOEF = KPCOEF + 1 + CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1, LDPCO2, + $ QCOEFF, LDQCO1, LDQCO2, INFO ) + END IF +C + IF ( ( .NOT.LROWCO ) .AND. ( MPLIM.NE.1 ) ) THEN +C +C If non-scalar T(s) originally given by columns, +C retranspose U(s). +C + DO 80 K = 1, KDCOEF +C + DO 70 J = 1, JSTOP + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, UCOEFF(J,J+1,K), + $ LDUCO1 ) + 70 CONTINUE +C + 80 CONTINUE +C + END IF + RETURN +C *** Last line of TD03AD *** + END diff --git a/mex/sources/libslicot/TD03AY.f b/mex/sources/libslicot/TD03AY.f new file mode 100644 index 000000000..90d53eee2 --- /dev/null +++ b/mex/sources/libslicot/TD03AY.f @@ -0,0 +1,171 @@ + SUBROUTINE TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, + $ LDUCO1, LDUCO2, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Calculates a state-space representation for a (PWORK x MWORK) +C transfer matrix given in the form of polynomial row vectors over +C common denominators (not necessarily lcd's). Such a description +C is simply the polynomial matrix representation +C +C T(s) = inv(D(s)) * U(s), +C +C where D(s) is diagonal with (I,I)-th element D:I(s) of degree +C INDEX(I); applying Wolovich's Observable Structure Theorem to +C this left matrix fraction then yields an equivalent state-space +C representation in observable companion form, of order +C N = sum(INDEX(I)). As D(s) is diagonal, the PWORK ordered +C 'non-trivial' columns of C and A are very simply calculated, these +C submatrices being diagonal and (INDEX(I) x 1) - block diagonal, +C respectively: finding B and D is also somewhat simpler than for +C general P(s) as dealt with in TC04AD. Finally, the state-space +C representation obtained here is not necessarily controllable +C (as D(s) and U(s) are not necessarily relatively left prime), but +C it is theoretically completely observable: however, its +C observability matrix may be poorly conditioned, so it is safer +C not to assume observability either. +C +C REVISIONS +C +C May 13, 1998. +C +C KEYWORDS +C +C Coprime matrix fraction, elementary polynomial operations, +C polynomial matrix, state-space representation, transfer matrix. +C +C ****************************************************************** +C + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, + $ LDUCO2, MWORK, N, PWORK +C .. Array Arguments .. + INTEGER INDEX(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DCOEFF(LDDCOE,*), UCOEFF(LDUCO1,LDUCO2,*) +C .. Local Scalars .. + INTEGER I, IA, IBIAS, INDCUR, JA, JMAX1, K + DOUBLE PRECISION ABSDIA, ABSDMX, BIGNUM, DIAG, SMLNUM, UMAX1, + $ TEMP +C .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH, IDAMAX +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DLASET, DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. Executable Statements .. +C + INFO = 0 +C +C Initialize A and C to be zero, apart from 1's on the subdiagonal +C of A. +C + CALL DLASET( 'Upper', N, N, ZERO, ZERO, A, LDA ) + IF ( N.GT.1 ) CALL DLASET( 'Lower', N-1, N-1, ZERO, ONE, A(2,1), + $ LDA ) +C + CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC ) +C +C Calculate B and D, as well as 'non-trivial' elements of A and C. +C Check if any leading coefficient of D(s) nearly zero: if so, exit. +C Caution is taken to avoid overflow. +C + SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) + BIGNUM = ONE / SMLNUM +C + IBIAS = 2 + JA = 0 +C + DO 20 I = 1, PWORK + ABSDIA = ABS( DCOEFF(I,1) ) + JMAX1 = IDAMAX( MWORK, UCOEFF(I,1,1), LDUCO1 ) + UMAX1 = ABS( UCOEFF(I,JMAX1,1) ) + IF ( ( ABSDIA.LT.SMLNUM ) .OR. + $ ( ABSDIA.LT.ONE .AND. UMAX1.GT.ABSDIA*BIGNUM ) ) THEN +C +C Error return. +C + INFO = I + RETURN + END IF + DIAG = ONE/DCOEFF(I,1) + INDCUR = INDEX(I) + IF ( INDCUR.NE.0 ) THEN + IBIAS = IBIAS + INDCUR + JA = JA + INDCUR + IF ( INDCUR.GE.1 ) THEN + JMAX1 = IDAMAX( INDCUR, DCOEFF(I,2), LDDCOE ) + ABSDMX = ABS( DCOEFF(I,JMAX1) ) + IF ( ABSDIA.GE.ONE ) THEN + IF ( UMAX1.GT.ONE ) THEN + IF ( ( ABSDMX/ABSDIA ).GT.( BIGNUM/UMAX1 ) ) THEN +C +C Error return. +C + INFO = I + RETURN + END IF + END IF + ELSE + IF ( UMAX1.GT.ONE ) THEN + IF ( ABSDMX.GT.( BIGNUM*ABSDIA )/UMAX1 ) THEN +C +C Error return. +C + INFO = I + RETURN + END IF + END IF + END IF + END IF +C +C I-th 'non-trivial' sub-vector of A given from coefficients +C of D:I(s), while I-th row block of B given from this and +C row I of U(s). +C + DO 10 K = 2, INDCUR + 1 + IA = IBIAS - K + TEMP = -DIAG*DCOEFF(I,K) + A(IA,JA) = TEMP +C + CALL DCOPY( MWORK, UCOEFF(I,1,K), LDUCO1, B(IA,1), LDB ) + CALL DAXPY( MWORK, TEMP, UCOEFF(I,1,1), LDUCO1, B(IA,1), + $ LDB ) + 10 CONTINUE +C + IF ( JA.LT.N ) A(JA+1,JA) = ZERO +C +C Finally, I-th 'non-trivial' entry of C and row of D obtained +C also. +C + C(I,JA) = DIAG + END IF +C + CALL DCOPY( MWORK, UCOEFF(I,1,1), LDUCO1, D(I,1), LDD ) + CALL DSCAL( MWORK, DIAG, D(I,1), LDD ) + 20 CONTINUE +C + RETURN +C *** Last line of TD03AY *** + END diff --git a/mex/sources/libslicot/TD04AD.f b/mex/sources/libslicot/TD04AD.f new file mode 100644 index 000000000..9297cee09 --- /dev/null +++ b/mex/sources/libslicot/TD04AD.f @@ -0,0 +1,425 @@ + SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF, + $ LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D, + $ LDD, TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a minimal state-space representation (A,B,C,D) for a +C proper transfer matrix T(s) given as either row or column +C polynomial vectors over denominator polynomials, possibly with +C uncancelled common terms. +C +C ARGUMENTS +C +C Mode Parameters +C +C ROWCOL CHARACTER*1 +C Indicates whether the transfer matrix T(s) is given as +C rows or columns over common denominators as follows: +C = 'R': T(s) is given as rows over common denominators; +C = 'C': T(s) is given as columns over common denominators. +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C INDEX (input) INTEGER array, dimension (porm), where porm = P, +C if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'. +C This array must contain the degrees of the denominator +C polynomials in D(s). +C +C DCOEFF (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef), +C where kdcoef = MAX(INDEX(I)) + 1. +C The leading porm-by-kdcoef part of this array must contain +C the coefficients of each denominator polynomial. +C DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of the +C I-th denominator polynomial in D(s), where +C K = 1,2,...,kdcoef. +C +C LDDCOE INTEGER +C The leading dimension of array DCOEFF. +C LDDCOE >= MAX(1,P) if ROWCOL = 'R'; +C LDDCOE >= MAX(1,M) if ROWCOL = 'C'. +C +C UCOEFF (input) DOUBLE PRECISION array, dimension +C (LDUCO1,LDUCO2,kdcoef) +C The leading P-by-M-by-kdcoef part of this array must +C contain the numerator matrix U(s); if ROWCOL = 'C', this +C array is modified internally but restored on exit, and the +C remainder of the leading MAX(M,P)-by-MAX(M,P)-by-kdcoef +C part is used as internal workspace. +C UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1) +C of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef; +C if ROWCOL = 'R' then iorj = I, otherwise iorj = J. +C Thus for ROWCOL = 'R', U(s) = +C diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...). +C +C LDUCO1 INTEGER +C The leading dimension of array UCOEFF. +C LDUCO1 >= MAX(1,P) if ROWCOL = 'R'; +C LDUCO1 >= MAX(1,M,P) if ROWCOL = 'C'. +C +C LDUCO2 INTEGER +C The second dimension of array UCOEFF. +C LDUCO2 >= MAX(1,M) if ROWCOL = 'R'; +C LDUCO2 >= MAX(1,M,P) if ROWCOL = 'C'. +C +C NR (output) INTEGER +C The order of the resulting minimal realization, i.e. the +C order of the state dynamics matrix A. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N), +C porm +C where N = SUM INDEX(I). +C I=1 +C The leading NR-by-NR part of this array contains the upper +C block Hessenberg state dynamics matrix A of a minimal +C realization. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P)) +C The leading NR-by-M part of this array contains the +C input/state matrix B of a minimal realization; the +C remainder of the leading N-by-MAX(M,P) part is used as +C internal workspace. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (output) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-NR part of this array contains the +C state/output matrix C of a minimal realization; the +C remainder of the leading MAX(M,P)-by-N part is used as +C internal workspace. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C D (output) DOUBLE PRECISION array, dimension (LDD,M), +C if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'. +C The leading P-by-M part of this array contains the direct +C transmission matrix D; if ROWCOL = 'C', the remainder of +C the leading MAX(M,P)-by-MAX(M,P) part is used as internal +C workspace. +C +C LDD INTEGER +C The leading dimension of array D. +C LDD >= MAX(1,P) if ROWCOL = 'R'; +C LDD >= MAX(1,M,P) if ROWCOL = 'C'. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determination when +C transforming (A, B, C). If the user sets TOL > 0, then +C the given value of TOL is used as a lower bound for the +C reciprocal condition number (see the description of the +C argument RCOND in the SLICOT routine MB03OD); a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance +C (determined by the SLICOT routine TB01UD) is used instead. +C +C Workspace +C +C IWORK INTEGER array, dimension (N+MAX(M,P)) +C On exit, if INFO = 0, the first nonzero elements of +C IWORK(1:N) return the orders of the diagonal blocks of A. +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)). +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, then i is the first integer for which +C ABS( DCOEFF(I,1) ) is so small that the calculations +C would overflow (see SLICOT Library routine TD03AY); +C that is, the leading coefficient of a polynomial is +C nearly zero; no state-space representation is +C calculated. +C +C METHOD +C +C The method for transfer matrices factorized by rows will be +C described here: T(s) factorized by columns is dealt with by +C operating on the dual T'(s). This description for T(s) is +C actually the left polynomial matrix representation +C +C T(s) = inv(D(s))*U(s), +C +C where D(s) is diagonal with its (I,I)-th polynomial element of +C degree INDEX(I). The first step is to check whether the leading +C coefficient of any polynomial element of D(s) is approximately +C zero; if so the routine returns with INFO > 0. Otherwise, +C Wolovich's Observable Structure Theorem is used to construct a +C state-space representation in observable companion form which +C is equivalent to the above polynomial matrix representation. +C The method is particularly easy here due to the diagonal form +C of D(s). This state-space representation is not necessarily +C controllable (as D(s) and U(s) are not necessarily relatively +C left prime), but it is in theory completely observable; however, +C its observability matrix may be poorly conditioned, so it is +C treated as a general state-space representation and SLICOT +C Library routine TB01PD is then called to separate out a minimal +C realization from this general state-space representation by means +C of orthogonal similarity transformations. +C +C REFERENCES +C +C [1] Patel, R.V. +C Computation of Minimal-Order State-Space Realizations and +C Observability Indices using Orthogonal Transformations. +C Int. J. Control, 33, pp. 227-246, 1981. +C +C [2] Wolovich, W.A. +C Linear Multivariable Systems, (Theorem 4.3.3). +C Springer-Verlag, 1974. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires 0(N ) operations. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, March 1998. +C Supersedes Release 3.0 routine TD01OD. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Controllability, elementary polynomial operations, minimal +C realization, polynomial matrix, state-space representation, +C transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER ROWCOL + INTEGER INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1, + $ LDUCO2, LDWORK, M, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INDEX(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DCOEFF(LDDCOE,*), DWORK(*), + $ UCOEFF(LDUCO1,LDUCO2,*) +C .. Local Scalars .. + LOGICAL LROCOC, LROCOR + INTEGER I, J, JSTOP, K, KDCOEF, MPLIM, MWORK, N, PWORK +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLASET, DSWAP, TB01PD, TB01XD, TD03AY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + LROCOR = LSAME( ROWCOL, 'R' ) + LROCOC = LSAME( ROWCOL, 'C' ) + MPLIM = MAX( 1, M, P ) +C +C Test the input scalar arguments. +C + IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( ( LROCOR .AND. LDDCOE.LT.MAX( 1, P ) ) .OR. + $ ( LROCOC .AND. LDDCOE.LT.MAX( 1, M ) ) ) THEN + INFO = -6 + ELSE IF( ( LROCOR .AND. LDUCO1.LT.MAX( 1, P ) ) .OR. + $ ( LROCOC .AND. LDUCO1.LT.MPLIM ) ) THEN + INFO = -8 + ELSE IF( ( LROCOR .AND. LDUCO2.LT.MAX( 1, M ) ) .OR. + $ ( LROCOC .AND. LDUCO2.LT.MPLIM ) ) THEN + INFO = -9 + END IF +C + N = 0 + IF ( INFO.EQ.0 ) THEN + IF ( LROCOR ) THEN +C +C Initialization for T(s) given as rows over common +C denominators. +C + PWORK = P + MWORK = M + ELSE +C +C Initialization for T(s) given as columns over common +C denominators. +C + PWORK = M + MWORK = P + END IF +C +C Calculate N, the order of the resulting state-space +C representation. +C + KDCOEF = 0 +C + DO 10 I = 1, PWORK + KDCOEF = MAX( KDCOEF, INDEX(I) ) + N = N + INDEX(I) + 10 CONTINUE +C + KDCOEF = KDCOEF + 1 +C + IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MPLIM ) THEN + INFO = -16 + ELSE IF( ( LROCOR .AND. LDD.LT.MAX( 1, P ) ) .OR. + $ ( LROCOC .AND. LDD.LT.MPLIM ) ) THEN + INFO = -18 + ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*M, 3*P ) ) ) THEN + INFO = -22 + END IF + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TD04AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( N, M, P ).EQ.0 ) THEN + NR = 0 + DWORK(1) = ONE + RETURN + END IF +C + IF ( LROCOC ) THEN +C +C Initialize the remainder of the leading +C MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero. +C + IF ( P.LT.M ) THEN +C + DO 20 K = 1, KDCOEF + CALL DLASET( 'Full', M-P, MPLIM, ZERO, ZERO, + $ UCOEFF(P+1,1,K), LDUCO1 ) + 20 CONTINUE +C + ELSE IF ( P.GT.M ) THEN +C + DO 30 K = 1, KDCOEF + CALL DLASET( 'Full', MPLIM, P-M, ZERO, ZERO, + $ UCOEFF(1,M+1,K), LDUCO1 ) + 30 CONTINUE +C + END IF +C + IF ( MPLIM.NE.1 ) THEN +C +C Non-scalar T(s) factorized by columns: transpose it (i.e. +C U(s)). +C + JSTOP = MPLIM - 1 +C + DO 50 K = 1, KDCOEF +C + DO 40 J = 1, JSTOP + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, + $ UCOEFF(J,J+1,K), LDUCO1 ) + 40 CONTINUE +C + 50 CONTINUE +C + END IF + END IF +C +C Construct non-minimal state-space representation (by Wolovich's +C Structure Theorem) which has transfer matrix T(s) or T'(s) as +C appropriate ... +C + CALL TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1, + $ LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO ) + IF ( INFO.GT.0 ) + $ RETURN +C +C and then separate out a minimal realization from this. +C +C Workspace: need N + MAX(N, 3*MWORK, 3*PWORK). +C + CALL TB01PD( 'Minimal', 'Scale', N, MWORK, PWORK, A, LDA, B, LDB, + $ C, LDC, NR, TOL, IWORK, DWORK, LDWORK, INFO ) +C + IF ( LROCOC ) THEN +C +C If T(s) originally factorized by columns, find dual of minimal +C state-space representation, and reorder the rows and columns +C to get an upper block Hessenberg state dynamics matrix. +C + K = IWORK(1)+IWORK(2)-1 + CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB, + $ C, LDC, D, LDD, INFO ) + IF ( MPLIM.NE.1 ) THEN +C +C Also, retranspose U(s) if this is non-scalar. +C + DO 70 K = 1, KDCOEF +C + DO 60 J = 1, JSTOP + CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1, + $ UCOEFF(J,J+1,K), LDUCO1 ) + 60 CONTINUE +C + 70 CONTINUE +C + END IF + END IF +C + RETURN +C *** Last line of TD04AD *** + END diff --git a/mex/sources/libslicot/TD05AD.f b/mex/sources/libslicot/TD05AD.f new file mode 100644 index 000000000..0b527c4aa --- /dev/null +++ b/mex/sources/libslicot/TD05AD.f @@ -0,0 +1,314 @@ + SUBROUTINE TD05AD( UNITF, OUTPUT, NP1, MP1, W, A, B, VALR, VALI, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C Given a complex valued rational function of frequency (transfer +C function) G(jW) this routine will calculate its complex value or +C its magnitude and phase for a specified frequency value. +C +C ARGUMENTS +C +C Mode Parameters +C +C UNITF CHARACTER*1 +C Indicates the choice of frequency unit as follows: +C = 'R': Input frequency W in radians/second; +C = 'H': Input frequency W in hertz. +C +C OUTPUT CHARACTER*1 +C Indicates the choice of co-ordinates for output as folows: +C = 'C': Cartesian co-ordinates (output real and imaginary +C parts of G(jW)); +C = 'P': Polar co-ordinates (output magnitude and phase +C of G(jW)). +C +C Input/Output Parameters +C +C NP1 (input) INTEGER +C The order of the denominator + 1, i.e. N + 1. NP1 >= 1. +C +C MP1 (input) INTEGER +C The order of the numerator + 1, i.e. M + 1. MP1 >= 1. +C +C W (input) DOUBLE PRECISION +C The frequency value W for which the transfer function is +C to be evaluated. +C +C A (input) DOUBLE PRECISION array, dimension (NP1) +C This array must contain the vector of denominator +C coefficients in ascending order of powers. That is, A(i) +C must contain the coefficient of (jW)**(i-1) for i = 1, +C 2,...,NP1. +C +C B (input) DOUBLE PRECISION array, dimension (MP1) +C This array must contain the vector of numerator +C coefficients in ascending order of powers. That is, B(i) +C must contain the coefficient of (jW)**(i-1) for i = 1, +C 2,...,MP1. +C +C VALR (output) DOUBLE PRECISION +C If OUTPUT = 'C', VALR contains the real part of G(jW). +C If OUTPUT = 'P', VALR contains the magnitude of G(jW) +C in dBs. +C +C VALI (output) DOUBLE PRECISION +C If OUTPUT = 'C', VALI contains the imaginary part of +C G(jW). +C If OUTPUT = 'P', VALI contains the phase of G(jW) in +C degrees. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1: if the frequency value W is a pole of G(jW), or all +C the coefficients of the A polynomial are zero. +C +C METHOD +C +C By substituting the values of A, B and W in the following +C formula: +C +C B(1)+B(2)*(jW)+B(3)*(jW)**2+...+B(MP1)*(jW)**(MP1-1) +C G(jW) = ---------------------------------------------------. +C A(1)+A(2)*(jW)+A(3)*(jW)**2+...+A(NP1)*(jW)**(NP1-1) +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C The algorithm requires 0(N+M) operations. +C +C CONTRIBUTORS +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TD01AD by Control Systems Research +C Group, Kingston Polytechnic, United Kingdom, March 1981. +C +C REVISIONS +C +C February 1997. +C February 22, 1998 (changed the name of TD01MD). +C +C KEYWORDS +C +C Elementary polynomial operations, frequency response, matrix +C fraction, polynomial matrix, state-space representation, transfer +C matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE, EIGHT, TWENTY, NINETY, ONE80, THRE60 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, EIGHT=8.0D0, + $ TWENTY=20.0D0, NINETY=90.0D0, ONE80 = 180.0D0, + $ THRE60=360.0D0 ) +C .. Scalar Arguments .. + CHARACTER OUTPUT, UNITF + INTEGER INFO, MP1, NP1 + DOUBLE PRECISION VALI, VALR, W +C .. Array Arguments .. + DOUBLE PRECISION A(*), B(*) +C .. Local Scalars .. + LOGICAL LOUTPU, LUNITF + INTEGER I, IPHASE, M, M2, N, N2, NPZERO, NZZERO + DOUBLE PRECISION BIMAG, BREAL, G, TIMAG, TREAL, TWOPI, W2, WC + COMPLEX*16 ZTEMP +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAPY2 + COMPLEX*16 ZLADIV + EXTERNAL DLAPY2, LSAME, ZLADIV +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, ATAN, DBLE, DCMPLX, DIMAG, LOG10, MAX, MOD, + $ SIGN +C .. Executable Statements .. +C + INFO = 0 + LUNITF = LSAME( UNITF, 'H' ) + LOUTPU = LSAME( OUTPUT, 'P' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LUNITF .AND. .NOT.LSAME( UNITF, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOUTPU .AND. .NOT.LSAME( OUTPUT, 'C' ) ) THEN + INFO = -2 + ELSE IF( NP1.LT.1 ) THEN + INFO = -3 + ELSE IF( MP1.LT.1 ) THEN + INFO = -4 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TD05AD', -INFO ) + RETURN + END IF +C + M = MP1 - 1 + N = NP1 - 1 + WC = W + TWOPI = EIGHT*ATAN( ONE ) + IF ( LUNITF ) WC = WC*TWOPI + W2 = WC**2 +C +C Determine the orders z (NZZERO) and p (NPZERO) of the factors +C (jW)**k in the numerator and denominator polynomials, by counting +C the zero trailing coefficients. The value of G(jW) will then be +C computed as (jW)**(z-p)*m(jW)/n(jW), for appropriate m and n. +C + I = 0 +C + 10 CONTINUE + I = I + 1 + IF ( I.LE.M ) THEN + IF ( B(I).EQ.ZERO ) GO TO 10 + END IF +C + NZZERO = I - 1 + I = 0 +C + 20 CONTINUE + I = I + 1 + IF ( I.LE.N ) THEN + IF ( A(I).EQ.ZERO ) GO TO 20 + END IF +C + NPZERO = I - 1 + IPHASE = NZZERO - NPZERO +C + M2 = MOD( M - NZZERO, 2 ) +C +C Add real parts of the numerator m(jW). +C + TREAL = B(MP1-M2) +C + DO 30 I = M - 1 - M2, NZZERO + 1, -2 + TREAL = B(I) - W2*TREAL + 30 CONTINUE +C +C Add imaginary parts of the numerator m(jW). +C + IF ( M.EQ.0 ) THEN + TIMAG = ZERO + ELSE + TIMAG = B(M+M2) +C + DO 40 I = M + M2 - 2, NZZERO + 2, -2 + TIMAG = B(I) - W2*TIMAG + 40 CONTINUE +C + TIMAG = TIMAG*WC + END IF +C + N2 = MOD( N - NPZERO, 2 ) +C +C Add real parts of the denominator n(jW). +C + BREAL = A(NP1-N2) +C + DO 50 I = N - 1 - N2, NPZERO + 1, -2 + BREAL = A(I) - W2*BREAL + 50 CONTINUE +C +C Add imaginary parts of the denominator n(jW). +C + IF ( N.EQ.0 ) THEN + BIMAG = ZERO + ELSE + BIMAG = A(N+N2) +C + DO 60 I = N + N2 - 2, NPZERO + 2, -2 + BIMAG = A(I) - W2*BIMAG + 60 CONTINUE +C + BIMAG = BIMAG*WC + END IF +C + IF ( ( MAX( ABS( BREAL ), ABS( BIMAG ) ).EQ.ZERO ) .OR. + $ ( W.EQ.ZERO .AND. IPHASE.LT.0 ) ) THEN +C +C Error return: The specified frequency W is a pole of G(jW), +C or all the coefficients of the A polynomial are zero. +C + INFO = 1 + ELSE +C +C Evaluate the complex number W**(z-p)*m(jW)/n(jW). +C + ZTEMP = + $ ZLADIV( DCMPLX( TREAL, TIMAG ), DCMPLX( BREAL, BIMAG ) ) + VALR = DBLE( ZTEMP )*WC**IPHASE + VALI = DIMAG( ZTEMP )*WC**IPHASE +C + IF ( .NOT.LOUTPU ) THEN +C +C Cartesian co-ordinates: Update the result for j**(z-p). +C + I = MOD( ABS( IPHASE ), 4 ) + IF ( ( IPHASE.GT.0 .AND. I.GT.1 ) .OR. + $ ( IPHASE.LT.0 .AND. ( I.EQ.1 .OR. I.EQ.2) ) ) THEN + VALR = -VALR + VALI = -VALI + END IF +C + IF ( MOD( I, 2 ).NE.0 ) THEN + G = VALR + VALR = -VALI + VALI = G + END IF +C + ELSE +C +C Polar co-ordinates: Compute the magnitude and phase. +C + G = DLAPY2( VALR, VALI ) +C + IF ( VALR.EQ.ZERO ) THEN + VALI = SIGN( NINETY, VALI ) + ELSE + VALI = ( ATAN( VALI/VALR )/TWOPI )*THRE60 + IF ( VALI.EQ.ZERO .AND. NZZERO.EQ.M .AND. NPZERO.EQ.N + $ .AND. B(NZZERO+1)*A(NPZERO+1).LT.ZERO ) + $ VALI = ONE80 + END IF +C + VALR = TWENTY*LOG10( G ) +C + IF ( IPHASE.NE.0 ) + $ VALI = VALI + DBLE( NZZERO - NPZERO )*NINETY + END IF +C + END IF +C + RETURN +C *** Last line of TD05AD *** + END diff --git a/mex/sources/libslicot/TF01MD.f b/mex/sources/libslicot/TF01MD.f new file mode 100644 index 000000000..1b33b81ca --- /dev/null +++ b/mex/sources/libslicot/TF01MD.f @@ -0,0 +1,233 @@ + SUBROUTINE TF01MD( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, + $ U, LDU, X, Y, LDY, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the output sequence of a linear time-invariant +C open-loop system given by its discrete-time state-space model +C (A,B,C,D), where A is an N-by-N general matrix. +C +C The initial state vector x(1) must be supplied by the user. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NY (input) INTEGER +C The number of output vectors y(k) to be computed. +C NY >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct link matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,NY) +C The leading M-by-NY part of this array must contain the +C input vector sequence u(k), for k = 1,2,...,NY. +C Specifically, the k-th column of U must contain u(k). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state vector +C x(1) which consists of the N initial states of the system. +C On exit, this array contains the final state vector +C x(NY+1) of the N states of the system at instant NY. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) +C The leading P-by-NY part of this array contains the output +C vector sequence y(1),y(2),...,y(NY) such that the k-th +C column of Y contains y(k) (the outputs at instant k), +C for k = 1,2,...,NY. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,P). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an initial state vector x(1), the output vector sequence +C y(1), y(2),..., y(NY) is obtained via the formulae +C +C x(k+1) = A x(k) + B u(k) +C y(k) = C x(k) + D u(k), +C +C where each element y(k) is a vector of length P containing the +C outputs at instant k and k = 1,2,...,NY. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately (N + M) x (N + P) x NY +C multiplications and additions. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01AD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. +C +C KEYWORDS +C +C Discrete-time system, multivariable system, state-space model, +C state-space representation, time response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER IK +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( NY.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDU.LT.MAX( 1, M ) ) THEN + INFO = -14 + ELSE IF( LDY.LT.MAX( 1, P ) ) THEN + INFO = -17 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01MD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( P, NY ).EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.0 ) THEN +C +C Non-dynamic system: compute the output vectors. +C + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) + ELSE + CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, + $ D, LDD, U, LDU, ZERO, Y, LDY ) + END IF + RETURN + END IF +C + DO 10 IK = 1, NY + CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, + $ Y(1,IK), 1 ) +C + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, + $ DWORK, 1 ) +C + CALL DCOPY( N, DWORK, 1, X, 1 ) + 10 CONTINUE +C + CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, + $ U, LDU, ONE, Y, LDY ) +C + RETURN +C *** Last line of TF01MD *** + END diff --git a/mex/sources/libslicot/TF01MX.f b/mex/sources/libslicot/TF01MX.f new file mode 100644 index 000000000..aaaf7aaff --- /dev/null +++ b/mex/sources/libslicot/TF01MX.f @@ -0,0 +1,457 @@ + SUBROUTINE TF01MX( N, M, P, NY, S, LDS, U, LDU, X, Y, LDY, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the output sequence of a linear time-invariant +C open-loop system given by its discrete-time state-space model +C with an (N+P)-by-(N+M) general system matrix S, +C +C ( A B ) +C S = ( ) . +C ( C D ) +C +C The initial state vector x(1) must be supplied by the user. +C +C The input and output trajectories are stored as in the SLICOT +C Library routine TF01MY. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NY (input) INTEGER +C The number of output vectors y(k) to be computed. +C NY >= 0. +C +C S (input) DOUBLE PRECISION array, dimension (LDS,N+M) +C The leading (N+P)-by-(N+M) part of this array must contain +C the system matrix S. +C +C LDS INTEGER +C The leading dimension of array S. LDS >= MAX(1,N+P). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NY-by-M part of this array must contain the +C input vector sequence u(k), for k = 1,2,...,NY. +C Specifically, the k-th row of U must contain u(k)'. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NY). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state vector +C x(1) which consists of the N initial states of the system. +C On exit, this array contains the final state vector +C x(NY+1) of the N states of the system at instant NY+1. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,P) +C The leading NY-by-P part of this array contains the output +C vector sequence y(1),y(2),...,y(NY) such that the k-th +C row of Y contains y(k)' (the outputs at instant k), +C for k = 1,2,...,NY. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,NY). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= 0, if MIN(N,P,NY) = 0; otherwise, +C LDWORK >= N+P, if M = 0; +C LDWORK >= 2*N+M+P, if M > 0. +C For better performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an initial state vector x(1), the output vector sequence +C y(1), y(2),..., y(NY) is obtained via the formulae +C +C ( x(k+1) ) ( x(k) ) +C ( ) = S ( ) , +C ( y(k) ) ( u(k) ) +C +C where each element y(k) is a vector of length P containing the +C outputs at instant k, and k = 1,2,...,NY. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately (N + M) x (N + P) x NY +C multiplications and additions. +C +C FURTHER COMMENTS +C +C The implementation exploits data locality as much as possible, +C given the workspace length. +C +C CONTRIBUTOR +C +C V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 2002. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, multivariable system, state-space model, +C state-space representation, time response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDS, LDU, LDWORK, LDY, M, N, NY, P +C .. Array Arguments .. + DOUBLE PRECISION DWORK(*), S(LDS,*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER I, IC, IU, IW, IY, J, JW, K, N2M, N2P, NB, NF, + $ NM, NP, NS +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + NP = N + P + NM = N + M + IW = NM + NP + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( NY.LT.0 ) THEN + INFO = -4 + ELSE IF( LDS.LT.MAX( 1, NP ) ) THEN + INFO = -6 + ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN + INFO = -8 + ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN + INFO = -11 + ELSE + IF( MIN( N, P, NY ).EQ.0 ) THEN + JW = 0 + ELSE IF( M.EQ.0 ) THEN + JW = NP + ELSE + JW = IW + END IF + IF( LDWORK.LT.JW ) + $ INFO = -13 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01MX', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( NY, P ).EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.0 ) THEN +C +C Non-dynamic system: compute the output vectors. +C + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) + ELSE + CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, + $ U, LDU, S, LDS, ZERO, Y, LDY ) + END IF + RETURN + END IF +C +C Determine the block size (taken as for LAPACK routine DGETRF). +C + NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) +C +C Find the number of state vectors, extended with inputs (if M > 0) +C and outputs, that can be accommodated in the provided workspace. +C + NS = MIN( LDWORK/JW, NB*NB/JW, NY ) + N2P = N + NP +C + IF ( M.EQ.0 ) THEN +C +C System with no inputs. +C Workspace: need N + P; +C prefer larger. +C + IF( NS.LE.1 .OR. NY*P.LE.NB*NB ) THEN + IY = N + 1 +C +C LDWORK < 2*(N+P), or small problem. +C One row of array Y is computed for each loop index value. +C + DO 10 I = 1, NY +C +C Compute +C +C /x(i+1)\ /A\ +C | | = | | * x(i). +C \ y(i) / \C/ +C + CALL DGEMV( 'NoTranspose', NP, N, ONE, S, LDS, X, 1, + $ ZERO, DWORK, 1 ) + CALL DCOPY( N, DWORK, 1, X, 1 ) + CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) + 10 CONTINUE +C + ELSE +C +C LDWORK >= 2*(N+P), and large problem. +C NS rows of array Y are computed before being saved. +C + NF = ( NY/NS )*NS + CALL DCOPY( N, X, 1, DWORK, 1 ) +C + DO 40 I = 1, NF, NS +C +C Compute the current NS extended state vectors in the +C workspace: +C +C /x(i+1)\ /A\ +C | | = | | * x(i), i = 1 : ns - 1. +C \ y(i) / \C/ +C + DO 20 IC = 1, ( NS - 1 )*NP, NP + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) + 20 CONTINUE +C +C Prepare the next iteration. +C + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) +C +C Transpose the NS output vectors in the corresponding part +C of Y (column-wise). +C + DO 30 J = 1, P + CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(I,J), 1 ) + Y(I+NS-1,J) = DWORK(N+J) + 30 CONTINUE +C + 40 CONTINUE +C + NS = NY - NF +C + IF ( NS.GT.1 ) THEN +C +C Compute similarly the last NS output vectors. +C + DO 50 IC = 1, ( NS - 1 )*NP, NP + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK(IC), 1, ZERO, DWORK(IC+NP), 1 ) + 50 CONTINUE +C + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK((NS-1)*NP+1), 1, ZERO, DWORK, 1 ) +C + DO 60 J = 1, P + CALL DCOPY( NS-1, DWORK(N2P+J), NP, Y(NF+1,J), 1 ) + Y(NF+NS,J) = DWORK(N+J) + 60 CONTINUE +C + ELSE IF ( NS.EQ.1 ) THEN +C +C Compute similarly the last NS = 1 output vectors. +C + CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) + CALL DGEMV( 'No transpose', NP, N, ONE, S, LDS, + $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) + CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) +C + END IF +C +C Set the final state vector. +C + CALL DCOPY( N, DWORK, 1, X, 1 ) +C + END IF +C + ELSE +C +C General case. +C Workspace: need 2*N + M + P; +C prefer larger. +C + CALL DCOPY( N, X, 1, DWORK, 1 ) +C + IF( NS.LE.1 .OR. NY*( M + P ).LE.NB*NB ) THEN + IU = N + 1 + JW = IU + M + IY = JW + N +C +C LDWORK < 2*(2*N+M+P), or small problem. +C One row of array Y is computed for each loop index value. +C + DO 70 I = 1, NY +C +C Compute +C +C /x(i+1)\ /A, B\ /x(i)\ +C | | = | | * | | . +C \ y(i) / \C, D/ \u(i)/ +C + CALL DCOPY( M, U(I,1), LDU, DWORK(IU), 1 ) + CALL DGEMV( 'NoTranspose', NP, NM, ONE, S, LDS, DWORK, 1, + $ ZERO, DWORK(JW), 1 ) + CALL DCOPY( N, DWORK(JW), 1, DWORK, 1 ) + CALL DCOPY( P, DWORK(IY), 1, Y(I,1), LDY ) + 70 CONTINUE +C + ELSE +C +C LDWORK >= 2*(2*N+M+P), and large problem. +C NS rows of array Y are computed before being saved. +C + NF = ( NY/NS )*NS + N2M = N + NM +C + DO 110 I = 1, NF, NS + JW = 1 +C +C Compute the current NS extended state vectors in the +C workspace: +C +C /x(i+1)\ /A, B\ /x(i)\ +C | | = | | * | | , i = 1 : ns - 1. +C \ y(i) / \C, D/ \u(i)/ +C + DO 80 J = 1, M + CALL DCOPY( NS, U(I,J), 1, DWORK(N+J), IW ) + 80 CONTINUE +C + DO 90 K = 1, NS - 1 + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) + JW = JW + NM + CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) + JW = JW + NP + 90 CONTINUE +C +C Prepare the next iteration. +C + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) + CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) +C +C Transpose the NS output vectors in the corresponding part +C of Y (column-wise). +C + DO 100 J = 1, P + CALL DCOPY( NS, DWORK(N2M+J), IW, Y(I,J), 1 ) + 100 CONTINUE +C + 110 CONTINUE +C + NS = NY - NF +C + IF ( NS.GT.1 ) THEN + JW = 1 +C +C Compute similarly the last NS output vectors. +C + DO 120 J = 1, M + CALL DCOPY( NS, U(NF+1,J), 1, DWORK(N+J), IW ) + 120 CONTINUE +C + DO 130 K = 1, NS - 1 + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) + JW = JW + NM + CALL DCOPY( N, DWORK(JW), 1, DWORK(JW+NP), 1 ) + JW = JW + NP + 130 CONTINUE +C + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(JW), 1, ZERO, DWORK(JW+NM), 1 ) + CALL DCOPY( N, DWORK(JW+NM), 1, DWORK, 1 ) +C + DO 140 J = 1, P + CALL DCOPY( NS, DWORK(N2M+J), IW, Y(NF+1,J), 1 ) + 140 CONTINUE +C + ELSE IF ( NS.EQ.1 ) THEN +C +C Compute similarly the last NS = 1 output vectors. +C + CALL DCOPY( N, DWORK, 1, DWORK(NP+1), 1 ) + CALL DCOPY( M, U(NF+1,1), LDU, DWORK(N2P+1), 1 ) + CALL DGEMV( 'No transpose', NP, NM, ONE, S, LDS, + $ DWORK(NP+1), 1, ZERO, DWORK, 1 ) + CALL DCOPY( P, DWORK(N+1), 1, Y(NF+1,1), LDY ) +C + END IF +C + END IF +C +C Set the final state vector. +C + CALL DCOPY( N, DWORK, 1, X, 1 ) +C + END IF +C + RETURN +C *** Last line of TF01MX *** + END diff --git a/mex/sources/libslicot/TF01MY.f b/mex/sources/libslicot/TF01MY.f new file mode 100644 index 000000000..85e31c05b --- /dev/null +++ b/mex/sources/libslicot/TF01MY.f @@ -0,0 +1,358 @@ + SUBROUTINE TF01MY( N, M, P, NY, A, LDA, B, LDB, C, LDC, D, LDD, + $ U, LDU, X, Y, LDY, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the output sequence of a linear time-invariant +C open-loop system given by its discrete-time state-space model +C (A,B,C,D), where A is an N-by-N general matrix. +C +C The initial state vector x(1) must be supplied by the user. +C +C This routine differs from SLICOT Library routine TF01MD in the +C way the input and output trajectories are stored. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NY (input) INTEGER +C The number of output vectors y(k) to be computed. +C NY >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading N-by-N part of this array must contain the +C state matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct link matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,M) +C The leading NY-by-M part of this array must contain the +C input vector sequence u(k), for k = 1,2,...,NY. +C Specifically, the k-th row of U must contain u(k)'. +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,NY). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state vector +C x(1) which consists of the N initial states of the system. +C On exit, this array contains the final state vector +C x(NY+1) of the N states of the system at instant NY+1. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,P) +C The leading NY-by-P part of this array contains the output +C vector sequence y(1),y(2),...,y(NY) such that the k-th +C row of Y contains y(k)' (the outputs at instant k), +C for k = 1,2,...,NY. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,NY). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. LDWORK >= N. +C For better performance, LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an initial state vector x(1), the output vector sequence +C y(1), y(2),..., y(NY) is obtained via the formulae +C +C x(k+1) = A x(k) + B u(k) +C y(k) = C x(k) + D u(k), +C +C where each element y(k) is a vector of length P containing the +C outputs at instant k and k = 1,2,...,NY. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately (N + M) x (N + P) x NY +C multiplications and additions. +C +C FURTHER COMMENTS +C +C The implementation exploits data locality and uses BLAS 3 +C operations as much as possible, given the workspace length. +C +C CONTRIBUTOR +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Discrete-time system, multivariable system, state-space model, +C state-space representation, time response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDWORK, LDY, M, + $ N, NY, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + INTEGER IK, IREM, IS, IYL, MAXN, NB, NS + DOUBLE PRECISION UPD +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + MAXN = MAX( 1, N ) + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( NY.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAXN ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAXN ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -12 + ELSE IF( LDU.LT.MAX( 1, NY ) ) THEN + INFO = -14 + ELSE IF( LDY.LT.MAX( 1, NY ) ) THEN + INFO = -17 + ELSE IF( LDWORK.LT.N ) THEN + INFO = -19 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01MY', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( NY, P ).EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.0 ) THEN +C +C Non-dynamic system: compute the output vectors. +C + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', NY, P, ZERO, ZERO, Y, LDY ) + ELSE + CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, + $ U, LDU, D, LDD, ZERO, Y, LDY ) + END IF + RETURN + END IF +C +C Determine the block size (taken as for LAPACK routine DGETRF). +C + NB = ILAENV( 1, 'DGETRF', ' ', NY, MAX( M, P ), -1, -1 ) +C +C Find the number of state vectors that can be accommodated in +C the provided workspace and initialize. +C + NS = MIN( LDWORK/N, NB*NB/N, NY ) +C + IF ( NS.LE.1 .OR. NY*MAX( M, P ).LE.NB*NB ) THEN +C +C LDWORK < 2*N or small problem: +C only BLAS 2 calculations are used in the loop +C for computing the output corresponding to D = 0. +C One row of the array Y is computed for each loop index value. +C + DO 10 IK = 1, NY + CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, X, 1, ZERO, + $ Y(IK,1), LDY ) +C + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, X, 1, ZERO, + $ DWORK, 1 ) + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(IK,1), LDU, + $ ONE, DWORK, 1 ) +C + CALL DCOPY( N, DWORK, 1, X, 1 ) + 10 CONTINUE +C + ELSE +C +C LDWORK >= 2*N and large problem: +C some BLAS 3 calculations can also be used. +C + IYL = ( NY/NS )*NS + IF ( M.EQ.0 ) THEN + UPD = ZERO + ELSE + UPD = ONE + END IF +C + CALL DCOPY( N, X, 1, DWORK, 1 ) +C + DO 30 IK = 1, IYL, NS +C +C Compute the current NS-1 state vectors in the workspace. +C + CALL DGEMM( 'No transpose', 'Transpose', N, NS-1, M, ONE, + $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) +C + DO 20 IS = 1, NS - 1 + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) + 20 CONTINUE +C +C Initialize the current NS output vectors. +C + CALL DGEMM( 'Transpose', 'Transpose', NS, P, N, ONE, DWORK, + $ MAXN, C, LDC, ZERO, Y(IK,1), LDY ) +C +C Prepare the next iteration. +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IK+NS-1,1), LDU, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK((NS-1)*N+1), 1, UPD, DWORK, 1 ) + 30 CONTINUE +C + IREM = NY - IYL +C + IF ( IREM.GT.1 ) THEN +C +C Compute the last IREM output vectors. +C First, compute the current IREM-1 state vectors. +C + IK = IYL + 1 + CALL DGEMM( 'No transpose', 'Transpose', N, IREM-1, M, ONE, + $ B, LDB, U(IK,1), LDU, ZERO, DWORK(N+1), MAXN ) +C + DO 40 IS = 1, IREM - 1 + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK((IS-1)*N+1), 1, UPD, DWORK(IS*N+1), 1 ) + 40 CONTINUE +C +C Initialize the last IREM output vectors. +C + CALL DGEMM( 'Transpose', 'Transpose', IREM, P, N, ONE, + $ DWORK, MAXN, C, LDC, ZERO, Y(IK,1), LDY ) +C +C Prepare the final state vector. +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IK+IREM-1,1), LDU, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK((IREM-1)*N+1), 1, UPD, DWORK, 1 ) +C + ELSE IF ( IREM.EQ.1 ) THEN +C +C Compute the last 1 output vectors. +C + CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, + $ ZERO, Y(IK,1), LDY ) +C +C Prepare the final state vector. +C + CALL DCOPY( N, DWORK, 1, DWORK(N+1), 1 ) + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, + $ U(IK,1), LDU, ZERO, DWORK, 1 ) + CALL DGEMV( 'No transpose', N, N, ONE, A, LDA, + $ DWORK(N+1), 1, UPD, DWORK, 1 ) + END IF +C +C Set the final state vector. +C + CALL DCOPY( N, DWORK, 1, X, 1 ) +C + END IF +C +C Add the direct contribution of the input to the output vectors. +C + CALL DGEMM( 'No transpose', 'Transpose', NY, P, M, ONE, U, LDU, + $ D, LDD, ONE, Y, LDY ) +C + RETURN +C *** Last line of TF01MY *** + END diff --git a/mex/sources/libslicot/TF01ND.f b/mex/sources/libslicot/TF01ND.f new file mode 100644 index 000000000..04676e7e5 --- /dev/null +++ b/mex/sources/libslicot/TF01ND.f @@ -0,0 +1,278 @@ + SUBROUTINE TF01ND( UPLO, N, M, P, NY, A, LDA, B, LDB, C, LDC, D, + $ LDD, U, LDU, X, Y, LDY, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute the output sequence of a linear time-invariant +C open-loop system given by its discrete-time state-space model +C (A,B,C,D), where A is an N-by-N upper or lower Hessenberg matrix. +C +C The initial state vector x(1) must be supplied by the user. +C +C ARGUMENTS +C +C Mode Parameters +C +C UPLO CHARACTER*1 +C Indicates whether the user wishes to use an upper or lower +C Hessenberg matrix as follows: +C = 'U': Upper Hessenberg matrix; +C = 'L': Lower Hessenberg matrix. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrix A. N >= 0. +C +C M (input) INTEGER +C The number of system inputs. M >= 0. +C +C P (input) INTEGER +C The number of system outputs. P >= 0. +C +C NY (input) INTEGER +C The number of output vectors y(k) to be computed. +C NY >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C If UPLO = 'U', the leading N-by-N upper Hessenberg part +C of this array must contain the state matrix A of the +C system. +C If UPLO = 'L', the leading N-by-N lower Hessenberg part +C of this array must contain the state matrix A of the +C system. +C The remainder of the leading N-by-N part is not +C referenced. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,M) +C The leading N-by-M part of this array must contain the +C input matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,N) +C The leading P-by-N part of this array must contain the +C output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C D (input) DOUBLE PRECISION array, dimension (LDD,M) +C The leading P-by-M part of this array must contain the +C direct link matrix D of the system. +C +C LDD INTEGER +C The leading dimension of array D. LDD >= MAX(1,P). +C +C U (input) DOUBLE PRECISION array, dimension (LDU,NY) +C The leading M-by-NY part of this array must contain the +C input vector sequence u(k), for k = 1,2,...,NY. +C Specifically, the k-th column of U must contain u(k). +C +C LDU INTEGER +C The leading dimension of array U. LDU >= MAX(1,M). +C +C X (input/output) DOUBLE PRECISION array, dimension (N) +C On entry, this array must contain the initial state vector +C x(1) which consists of the N initial states of the system. +C On exit, this array contains the final state vector +C x(NY+1) of the N states of the system at instant NY. +C +C Y (output) DOUBLE PRECISION array, dimension (LDY,NY) +C The leading P-by-NY part of this array contains the output +C vector sequence y(1),y(2),...,y(NY) such that the k-th +C column of Y contains y(k) (the outputs at instant k), +C for k = 1,2,...,NY. +C +C LDY INTEGER +C The leading dimension of array Y. LDY >= MAX(1,P). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (N) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Given an initial state vector x(1), the output vector sequence +C y(1), y(2),..., y(NY) is obtained via the formulae +C +C x(k+1) = A x(k) + B u(k) +C y(k) = C x(k) + D u(k), +C +C where each element y(k) is a vector of length P containing the +C outputs at instant k and k = 1,2,...,NY. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately ((N+M)xP + (N/2+M)xN) x NY +C multiplications and additions. +C +C FURTHER COMMENTS +C +C The processing time required by this routine will be approximately +C half that required by the SLICOT Library routine TF01MD, which +C treats A as a general matrix. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01BD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Apr. 2003. +C +C KEYWORDS +C +C Discrete-time system, Hessenberg form, multivariable system, +C state-space model, state-space representation, time response. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDB, LDC, LDD, LDU, LDY, M, N, NY, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), + $ DWORK(*), U(LDU,*), X(*), Y(LDY,*) +C .. Local Scalars .. + LOGICAL LUPLO + INTEGER I, IK +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DLASET, DTRMV, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 + LUPLO = LSAME( UPLO, 'U' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( NY.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDD.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDU.LT.MAX( 1, M ) ) THEN + INFO = -15 + ELSE IF( LDY.LT.MAX( 1, P ) ) THEN + INFO = -18 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01ND', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( P, NY ).EQ.0 ) THEN + RETURN + ELSE IF ( N.EQ.0 ) THEN +C +C Non-dynamic system: compute the output vectors. +C + IF ( M.EQ.0 ) THEN + CALL DLASET( 'Full', P, NY, ZERO, ZERO, Y, LDY ) + ELSE + CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, + $ D, LDD, U, LDU, ZERO, Y, LDY ) + END IF + RETURN + END IF +C + CALL DCOPY( N, X, 1, DWORK, 1 ) +C + DO 30 IK = 1, NY + CALL DGEMV( 'No transpose', P, N, ONE, C, LDC, DWORK, 1, ZERO, + $ Y(1,IK), 1 ) +C + CALL DTRMV( UPLO, 'No transpose', 'Non-unit', N, A, LDA, + $ DWORK, 1 ) +C + IF ( LUPLO ) THEN +C + DO 10 I = 2, N + DWORK(I) = DWORK(I) + A(I,I-1)*X(I-1) + 10 CONTINUE +C + ELSE +C + DO 20 I = 1, N - 1 + DWORK(I) = DWORK(I) + A(I,I+1)*X(I+1) + 20 CONTINUE +C + END IF +C + CALL DGEMV( 'No transpose', N, M, ONE, B, LDB, U(1,IK), 1, ONE, + $ DWORK, 1 ) +C + CALL DCOPY( N, DWORK, 1, X, 1 ) + 30 CONTINUE +C + CALL DGEMM( 'No transpose', 'No transpose', P, NY, M, ONE, D, LDD, + $ U, LDU, ONE, Y, LDY ) +C + RETURN +C *** Last line of TF01ND *** + END diff --git a/mex/sources/libslicot/TF01OD.f b/mex/sources/libslicot/TF01OD.f new file mode 100644 index 000000000..656d86c9d --- /dev/null +++ b/mex/sources/libslicot/TF01OD.f @@ -0,0 +1,179 @@ + SUBROUTINE TF01OD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the block Hankel expansion T of a multivariable +C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) +C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NH1 (input) INTEGER +C The number of rows in each parameter M(k). NH1 >= 0. +C +C NH2 (input) INTEGER +C The number of columns in each parameter M(k). NH2 >= 0. +C +C NR (input) INTEGER +C The number of parameters required in each column of the +C block Hankel expansion matrix T. NR >= 0. +C +C NC (input) INTEGER +C The number of parameters required in each row of the +C block Hankel expansion matrix T. NC >= 0. +C +C H (input) DOUBLE PRECISION array, dimension +C (LDH,(NR+NC-1)*NH2) +C The leading NH1-by-(NR+NC-1)*NH2 part of this array must +C contain the multivariable sequence M(k), where k = 1,2, +C ...,(NR+NC-1). Specifically, each parameter M(k) is an +C NH1-by-NH2 matrix whose (i,j)-th element must be stored in +C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,NH1). +C +C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) +C The leading NH1*NR-by-NH2*NC part of this array contains +C the block Hankel expansion of the multivariable sequence +C M(k). +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,NH1*NR). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The NH1-by-NH2 dimensional parameters M(k) of a multivariable +C sequence are arranged into a matrix T in Hankel form such that +C +C +C | M(1) M(2) M(3) . . . M(NC) | +C | | +C | M(2) M(3) M(4) . . . M(NC+1) | +C T = | . . . . |. +C | . . . . | +C | . . . . | +C | | +C | M(NR) M(NR+1) M(NR+2) . . . M(NR+NC-1)| +C +C REFERENCES +C +C [1] Johvidov, J.S. +C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, +C (translated by G.P.A. Thijsse, I. Gohberg, ed.). +C Birkhaeuser, Boston, 1982. +C +C NUMERICAL ASPECTS +C +C The time taken is approximately proportional to +C NH1 x NH2 x NR x NC. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01CD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Hankel matrix, multivariable system. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR +C .. Array Arguments .. + DOUBLE PRECISION H(LDH,*), T(LDT,*) +C .. Local Scalars .. + INTEGER IH, IT, JT, NROW +C .. External Subroutines .. + EXTERNAL DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NH1.LT.0 ) THEN + INFO = -1 + ELSE IF( NH2.LT.0 ) THEN + INFO = -2 + ELSE IF( NR.LT.0 ) THEN + INFO = -3 + ELSE IF( NC.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN + INFO = -6 + ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01OD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) + $ RETURN +C +C Construct the first block column of T. +C + IH = 1 + NROW = (NR-1)*NH1 +C + DO 10 IT = 1, NROW+NH1, NH1 + CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,1), LDT ) + IH = IH + NH2 + 10 CONTINUE +C +C Construct the remaining block columns of T. +C + DO 20 JT = NH2+1, NC*NH2, NH2 + CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT-NH2), LDT, T(1,JT), + $ LDT ) + CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), + $ LDT ) + IH = IH + NH2 + 20 CONTINUE +C + RETURN +C *** Last line of TF01OD *** + END diff --git a/mex/sources/libslicot/TF01PD.f b/mex/sources/libslicot/TF01PD.f new file mode 100644 index 000000000..e45f078b6 --- /dev/null +++ b/mex/sources/libslicot/TF01PD.f @@ -0,0 +1,178 @@ + SUBROUTINE TF01PD( NH1, NH2, NR, NC, H, LDH, T, LDT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To construct the block Toeplitz expansion T of a multivariable +C parameter sequence M(1),...,M(NR+NC-1), where each parameter M(k) +C is an NH1-by-NH2 block matrix and k = 1,2,...,(NR+NC-1). +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NH1 (input) INTEGER +C The number of rows in each parameter M(k). NH1 >= 0. +C +C NH2 (input) INTEGER +C The number of columns in each parameter M(k). NH2 >= 0. +C +C NR (input) INTEGER +C The number of parameters required in each column of the +C block Toeplitz expansion matrix T. NR >= 0. +C +C NC (input) INTEGER +C The number of parameters required in each row of the +C block Toeplitz expansion matrix T. NC >= 0. +C +C H (input) DOUBLE PRECISION array, dimension +C (LDH,(NR+NC-1)*NH2) +C The leading NH1-by-(NR+NC-1)*NH2 part of this array must +C contain the multivariable sequence M(k), where k = 1,2, +C ...,(NR+NC-1). Specifically, each parameter M(k) is an +C NH1-by-NH2 matrix whose (i,j)-th element must be stored in +C H(i,(k-1)*NH2+j) for i = 1,2,...,NH1 and j = 1,2,...,NH2. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,NH1). +C +C T (output) DOUBLE PRECISION array, dimension (LDT,NH2*NC) +C The leading NH1*NR-by-NH2*NC part of this array contains +C the block Toeplitz expansion of the multivariable sequence +C M(k). +C +C LDT INTEGER +C The leading dimension of array T. LDT >= MAX(1,NH1*NR). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The NH1-by-NH2 dimensional parameters M(k) of a multivariable +C sequence are arranged into a matrix T in Toeplitz form such that +C +C | M(NC) M(NC-1) M(NC-2) . . . M(1) | +C | | +C | M(NC+1) M(NC) M(NC-1) . . . M(2) | +C T = | . . . . |. +C | . . . . | +C | . . . . | +C | | +C | M(NR+NC-1) M(NR+NC-2) M(NR+NC-3) . . . M(NR) | +C +C REFERENCES +C +C [1] Johvidov, J.S. +C Hankel and Toeplitz Matrices and Forms: Algebraic Theory, +C (translated by G.P.A. Thijsse, I. Gohberg, ed.). +C Birkhaeuser, Boston, 1982. +C +C NUMERICAL ASPECTS +C +C The time taken is approximately proportional to +C NH1 x NH2 x NR x NC. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01DD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Multivariable system, Toeplitz matrix. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, LDH, LDT, NC, NH1, NH2, NR +C .. Array Arguments .. + DOUBLE PRECISION H(LDH,*), T(LDT,*) +C .. Local Scalars .. + INTEGER IH, IT, JT, NCOL, NROW +C .. External Subroutines .. + EXTERNAL DLACPY, XERBLA +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NH1.LT.0 ) THEN + INFO = -1 + ELSE IF( NH2.LT.0 ) THEN + INFO = -2 + ELSE IF( NR.LT.0 ) THEN + INFO = -3 + ELSE IF( NC.LT.0 ) THEN + INFO = -4 + ELSE IF( LDH.LT.MAX( 1, NH1 ) ) THEN + INFO = -6 + ELSE IF( LDT.LT.MAX( 1, NH1*NR ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01PD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( NH1, NH2, NR, NC ).EQ.0 ) + $ RETURN +C +C Construct the last block column of T. +C + IH = 1 + NROW = (NR-1)*NH1 + NCOL = (NC-1)*NH2 + 1 +C + DO 10 IT = 1, NROW+NH1, NH1 + CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(IT,NCOL), + $ LDT ) + IH = IH + NH2 + 10 CONTINUE +C +C Construct the remaining block columns of T in backward order. +C + DO 20 JT = NCOL-NH2, 1, -NH2 + CALL DLACPY( 'Full', NROW, NH2, T(NH1+1,JT+NH2), LDT, T(1,JT), + $ LDT ) + CALL DLACPY( 'Full', NH1, NH2, H(1,IH), LDH, T(NROW+1,JT), + $ LDT ) + IH = IH + NH2 + 20 CONTINUE +C + RETURN +C *** Last line of TF01PD *** + END diff --git a/mex/sources/libslicot/TF01QD.f b/mex/sources/libslicot/TF01QD.f new file mode 100644 index 000000000..a2d3696ce --- /dev/null +++ b/mex/sources/libslicot/TF01QD.f @@ -0,0 +1,234 @@ + SUBROUTINE TF01QD( NC, NB, N, IORD, AR, MA, H, LDH, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute N Markov parameters M(1), M(2),..., M(N) from a +C multivariable system whose transfer function matrix G(z) is given. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NC (input) INTEGER +C The number of system outputs, i.e. the number of rows in +C the transfer function matrix G(z). NC >= 0. +C +C NB (input) INTEGER +C The number of system inputs, i.e. the number of columns in +C the transfer function matrix G(z). NB >= 0. +C +C N (input) INTEGER +C The number of Markov parameters M(k) to be computed. +C N >= 0. +C +C IORD (input) INTEGER array, dimension (NC*NB) +C This array must contain the order r of the elements of the +C transfer function matrix G(z), stored row by row. +C For example, the order of the (i,j)-th element of G(z) is +C given by IORD((i-1)xNB+j). +C +C AR (input) DOUBLE PRECISION array, dimension (NA), where +C NA = IORD(1) + IORD(2) + ... + IORD(NC*NB). +C The leading NA elements of this array must contain the +C denominator coefficients AR(1),...,AR(r) in equation (1) +C of the (i,j)-th element of the transfer function matrix +C G(z), stored row by row, i.e. in the order +C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., +C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given +C in decreasing order of powers of z; the coefficient of the +C highest order term is assumed to be equal to 1. +C +C MA (input) DOUBLE PRECISION array, dimension (NA) +C The leading NA elements of this array must contain the +C numerator coefficients MA(1),...,MA(r) in equation (1) +C of the (i,j)-th element of the transfer function matrix +C G(z), stored row by row, i.e. in the order +C (1,1),(1,2),...,(1,NB), (2,1),(2,2),...,(2,NB), ..., +C (NC,1),(NC,2),...,(NC,NB). The coefficients must be given +C in decreasing order of powers of z. +C +C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) +C The leading NC-by-N*NB part of this array contains the +C multivariable Markov parameter sequence M(k), where each +C parameter M(k) is an NC-by-NB matrix and k = 1,2,...,N. +C The Markov parameters are stored such that H(i,(k-1)xNB+j) +C contains the (i,j)-th element of M(k) for i = 1,2,...,NC +C and j = 1,2,...,NB. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,NC). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The (i,j)-th element of G(z), defining the particular I/O transfer +C between output i and input j, has the following form: +C +C -1 -2 -r +C MA(1)z + MA(2)z + ... + MA(r)z +C G (z) = ----------------------------------------. (1) +C ij -1 -2 -r +C 1 + AR(1)z + AR(2)z + ... + AR(r)z +C +C The (i,j)-th element of G(z) is defined by its order r, its r +C moving average coefficients (= numerator) MA(1),...,MA(r) and its +C r autoregressive coefficients (= denominator) AR(1),...,AR(r). The +C coefficient of the constant term in the denominator is assumed to +C be equal to 1. +C +C The relationship between the (i,j)-th element of the Markov +C parameters M(1),M(2),...,M(N) and the corresponding element of the +C transfer function matrix G(z) is given by: +C +C -1 -2 -k +C G (z) = M (0) + M (1)z + M (2)z + ... + M (k)z + ...(2) +C ij ij ij ij ij +C +C Equating (1) and (2), we find that the relationship between the +C (i,j)-th element of the Markov parameters M(k) and the ARMA +C parameters AR(1),...,AR(r) and MA(1),...,MA(r) of the (i,j)-th +C element of the transfer function matrix G(z) is as follows: +C +C M (1) = MA(1), +C ij +C k-1 +C M (k) = MA(k) - SUM AR(p) x M (k-p) for 1 < k <= r and +C ij p=1 ij +C r +C M (k+r) = - SUM AR(p) x M (k+r-p) for k > 0. +C ij p=1 ij +C +C From these expressions the Markov parameters M(k) are computed +C element by element. +C +C REFERENCES +C +C [1] Luenberger, D.G. +C Introduction to Dynamic Systems: Theory, Models and +C Applications. +C John Wiley & Sons, New York, 1979. +C +C NUMERICAL ASPECTS +C +C The computation of the (i,j)-th element of M(k) requires: +C (k-1) multiplications and k additions if k <= r; +C r multiplications and r additions if k > r. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01ED by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Markov parameters, multivariable system, transfer function, +C transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDH, N, NB, NC +C .. Array Arguments .. + INTEGER IORD(*) + DOUBLE PRECISION AR(*), H(LDH,*), MA(*) +C .. Local Scalars .. + INTEGER I, J, JJ, JK, K, KI, LDHNB, NL, NORD +C .. External Functions .. + DOUBLE PRECISION DDOT + EXTERNAL DDOT +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NC.LT.0 ) THEN + INFO = -1 + ELSE IF( NB.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01QD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MAX( NC, NB, N ).EQ.0 ) + $ RETURN +C + LDHNB = LDH*NB + NL = 1 + K = 1 +C + DO 60 I = 1, NC +C + DO 50 J = 1, NB + NORD = IORD(K) + H(I,J) = MA(NL) + JK = J +C + DO 20 KI = 1, NORD - 1 + JK = JK + NB + H(I,JK) = MA(NL+KI) - DDOT( KI, AR(NL), 1, H(I,J), + $ -LDHNB ) + 20 CONTINUE +C + DO 40 JJ = J, J + (N - NORD - 1)*NB, NB + JK = JK + NB + H(I,JK) = -DDOT( NORD, AR(NL), 1, H(I,JJ), -LDHNB ) + 40 CONTINUE +C + NL = NL + NORD + K = K + 1 + 50 CONTINUE +C + 60 CONTINUE +C + RETURN +C *** Last line of TF01QD *** + END diff --git a/mex/sources/libslicot/TF01RD.f b/mex/sources/libslicot/TF01RD.f new file mode 100644 index 000000000..d28a6ed98 --- /dev/null +++ b/mex/sources/libslicot/TF01RD.f @@ -0,0 +1,230 @@ + SUBROUTINE TF01RD( NA, NB, NC, N, A, LDA, B, LDB, C, LDC, H, LDH, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute N Markov parameters M(1), M(2),..., M(N) from the +C parameters (A,B,C) of a linear time-invariant system, where each +C M(k) is an NC-by-NB matrix and k = 1,2,...,N. +C +C All matrices are treated as dense, and hence TF01RD is not +C intended for large sparse problems. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C NA (input) INTEGER +C The order of the matrix A. NA >= 0. +C +C NB (input) INTEGER +C The number of system inputs. NB >= 0. +C +C NC (input) INTEGER +C The number of system outputs. NC >= 0. +C +C N (input) INTEGER +C The number of Markov parameters M(k) to be computed. +C N >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,NA) +C The leading NA-by-NA part of this array must contain the +C state matrix A of the system. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,NA). +C +C B (input) DOUBLE PRECISION array, dimension (LDB,NB) +C The leading NA-by-NB part of this array must contain the +C input matrix B of the system. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,NA). +C +C C (input) DOUBLE PRECISION array, dimension (LDC,NA) +C The leading NC-by-NA part of this array must contain the +C output matrix C of the system. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,NC). +C +C H (output) DOUBLE PRECISION array, dimension (LDH,N*NB) +C The leading NC-by-N*NB part of this array contains the +C multivariable parameters M(k), where each parameter M(k) +C is an NC-by-NB matrix and k = 1,2,...,N. The Markov +C parameters are stored such that H(i,(k-1)xNB+j) contains +C the (i,j)-th element of M(k) for i = 1,2,...,NC and +C j = 1,2,...,NB. +C +C LDH INTEGER +C The leading dimension of array H. LDH >= MAX(1,NC). +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, 2*NA*NC). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C For the linear time-invariant discrete-time system +C +C x(k+1) = A x(k) + B u(k) +C y(k) = C x(k) + D u(k), +C +C the transfer function matrix G(z) is given by +C -1 +C G(z) = C(zI-A) B + D +C -1 -2 2 -3 +C = D + CB z + CAB z + CA B z + ... (1) +C +C Using Markov parameters, G(z) can also be written as +C -1 -2 -3 +C G(z) = M(0) + M(1)z + M(2)z + M(3)z + ... (2) +C +C k-1 +C Equating (1) and (2), we find that M(0) = D and M(k) = C A B +C for k > 0, from which the Markov parameters M(1),M(2)...,M(N) are +C computed. +C +C REFERENCES +C +C [1] Chen, C.T. +C Introduction to Linear System Theory. +C H.R.W. Series in Electrical Engineering, Electronics and +C Systems, Holt, Rinehart and Winston Inc., London, 1970. +C +C NUMERICAL ASPECTS +C +C The algorithm requires approximately (NA + NB) x NA x NC x N +C multiplications and additions. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996. +C Supersedes Release 2.0 routine TF01FD by S. Van Huffel, Katholieke +C Univ. Leuven, Belgium. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Markov parameters, multivariable system, time-invariant system, +C transfer function, transfer matrix. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDH, LDWORK, N, NA, NB, NC +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), H(LDH,*) +C .. Local Scalars .. + INTEGER I, JWORK, K, LDW +C .. External Subroutines .. + EXTERNAL DGEMM, DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( NA.LT.0 ) THEN + INFO = -1 + ELSE IF( NB.LT.0 ) THEN + INFO = -2 + ELSE IF( NC.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, NA ) ) THEN + INFO = -6 + ELSE IF( LDB.LT.MAX( 1, NA ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, NC ) ) THEN + INFO = -10 + ELSE IF( LDH.LT.MAX( 1, NC ) ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.MAX( 1, 2*NA*NC ) ) THEN + INFO = -14 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TF01RD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF ( MIN( NA, NB, NC, N ).EQ.0 ) + $ RETURN +C + JWORK = 1 + NC*NA + LDW = MAX( 1, NC ) + I = 1 +C +C Copy C in the workspace beginning from the position JWORK. +C This workspace will contain the product C*A**(K-1), K = 1,2,...,N. +C + CALL DLACPY( 'Full', NC, NA, C, LDC, DWORK(JWORK), LDW ) +C +C Form M(1), M(2), ..., M(N). +C + DO 10 K = 1, N + CALL DLACPY( 'Full', NC, NA, DWORK(JWORK), LDW, DWORK, LDW ) +C +C Form (C * A**(K-1)) * B = M(K). +C + CALL DGEMM( 'No transpose', 'No transpose', NC, NB, NA, ONE, + $ DWORK, LDW, B, LDB, ZERO, H(1,I), LDH ) +C + IF ( K.NE.N ) THEN +C +C Form C * A**K. +C + CALL DGEMM( 'No transpose', 'No transpose', NC, NA, NA, ONE, + $ DWORK, LDW, A, LDA, ZERO, DWORK(JWORK), LDW ) +C + I = I + NB + END IF + 10 CONTINUE +C + RETURN +C *** Last line of TF01RD *** + END diff --git a/mex/sources/libslicot/TG01AD.f b/mex/sources/libslicot/TG01AD.f new file mode 100644 index 000000000..5bae2d7bf --- /dev/null +++ b/mex/sources/libslicot/TG01AD.f @@ -0,0 +1,513 @@ + SUBROUTINE TG01AD( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, + $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To balance the matrices of the system pencil +C +C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, +C ( C 0 ) ( 0 0 ) +C +C corresponding to the descriptor triple (A-lambda E,B,C), +C by balancing. This involves diagonal similarity transformations +C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system +C (A-lambda E,B,C) to make the rows and columns of system pencil +C matrices +C +C diag(Dl,I) * S * diag(Dr,I) +C +C as close in norm as possible. Balancing may reduce the 1-norms +C of the matrices of the system pencil S. +C +C The balancing can be performed optionally on the following +C particular system pencils +C +C S = A-lambda E, +C +C S = ( A-lambda E B ), or +C +C S = ( A-lambda E ). +C ( C ) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates which matrices are involved in balancing, as +C follows: +C = 'A': All matrices are involved in balancing; +C = 'B': B, A and E matrices are involved in balancing; +C = 'C': C, A and E matrices are involved in balancing; +C = 'N': B and C matrices are not involved in balancing. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C THRESH (input) DOUBLE PRECISION +C Threshold value for magnitude of elements: +C elements with magnitude less than or equal to +C THRESH are ignored for balancing. THRESH >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the balanced matrix Dl*A*Dr. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the balanced matrix Dl*E*Dr. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, if M > 0, the leading L-by-M part of this array +C contains the balanced matrix Dl*B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the balanced matrix C*Dr. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C LSCALE (output) DOUBLE PRECISION array, dimension (L) +C The scaling factors applied to S from left. If Dl(j) is +C the scaling factor applied to row j, then +C SCALE(j) = Dl(j), for j = 1,...,L. +C +C RSCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to S from right. If Dr(j) is +C the scaling factor applied to column j, then +C SCALE(j) = Dr(j), for j = 1,...,N. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*(L+N)) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation +C -1 +C diag(Dl,I) * S * diag(Dr,I) +C +C to make the 1-norms of each row of the first L rows of S and its +C corresponding N columns nearly equal. +C +C Information about the diagonal matrices Dl and Dr are returned in +C the vectors LSCALE and RSCALE, respectively. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C [2] R.C. Ward, R. C. +C Balancing the generalized eigenvalue problem. +C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the LAPACK routine DGGBAL. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C May 2003, March 2004, Jan. 2009. +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION HALF, ONE, ZERO + PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) + DOUBLE PRECISION SCLFAC, THREE + PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P + DOUBLE PRECISION THRESH +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), LSCALE( * ), + $ RSCALE( * ) +C .. Local Scalars .. + LOGICAL WITHB, WITHC + INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, + $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, + $ NRP2 + DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, + $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, + $ SFMIN, SUM, T, TA, TB, TC, TE +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN +C +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) + WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) +C + IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01AD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DUM( 1 ) = ONE + IF( L.GT.0 ) THEN + CALL DCOPY( L, DUM, 0, LSCALE, 1 ) + ELSE IF( N.GT.0 ) THEN + CALL DCOPY( N, DUM, 0, RSCALE, 1 ) + END IF + RETURN + END IF +C +C Initialize balancing and allocate work storage. +C + KW1 = N + KW2 = KW1 + L + KW3 = KW2 + L + KW4 = KW3 + N + KW5 = KW4 + L + DUM( 1 ) = ZERO + CALL DCOPY( L, DUM, 0, LSCALE, 1 ) + CALL DCOPY( N, DUM, 0, RSCALE, 1 ) + CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) +C +C Compute right side vector in resulting linear equations. +C + BASL = LOG10( SCLFAC ) + DO 20 I = 1, L + DO 10 J = 1, N + TE = ABS( E( I, J ) ) + TA = ABS( A( I, J ) ) + IF( TA.GT.THRESH ) THEN + TA = LOG10( TA ) / BASL + ELSE + TA = ZERO + END IF + IF( TE.GT.THRESH ) THEN + TE = LOG10( TE ) / BASL + ELSE + TE = ZERO + END IF + DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE + DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE + 10 CONTINUE + 20 CONTINUE +C + IF( M.EQ.0 ) THEN + WITHB = .FALSE. + TB = ZERO + END IF + IF( P.EQ.0 ) THEN + WITHC = .FALSE. + TC = ZERO + END IF +C + IF( WITHB ) THEN + DO 30 I = 1, L + J = IDAMAX( M, B( I, 1 ), LDB ) + TB = ABS( B( I, J ) ) + IF( TB.GT.THRESH ) THEN + TB = LOG10( TB ) / BASL + DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB + END IF + 30 CONTINUE + END IF +C + IF( WITHC ) THEN + DO 40 J = 1, N + I = IDAMAX( P, C( 1, J ), 1 ) + TC = ABS( C( I, J ) ) + IF( TC.GT.THRESH ) THEN + TC = LOG10( TC ) / BASL + DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC + END IF + 40 CONTINUE + END IF +C + COEF = ONE / DBLE( L+N ) + COEF2 = COEF*COEF + COEF5 = HALF*COEF2 + NRP2 = MAX( L, N ) + 2 + BETA = ZERO + IT = 1 +C +C Start generalized conjugate gradient iteration. +C + 50 CONTINUE +C + GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + + $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) +C + EW = ZERO + DO 60 I = 1, L + EW = EW + DWORK( I+KW4 ) + 60 CONTINUE +C + EWC = ZERO + DO 70 I = 1, N + EWC = EWC + DWORK( I+KW5 ) + 70 CONTINUE +C + GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - + $ COEF5*( EW - EWC )**2 + IF( GAMMA.EQ.ZERO ) + $ GO TO 160 + IF( IT.NE.1 ) + $ BETA = GAMMA / PGAMMA + T = COEF5*( EWC - THREE*EW ) + TC = COEF5*( EW - THREE*EWC ) +C + CALL DSCAL( N+L, BETA, DWORK, 1 ) +C + CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) + CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) +C + DO 80 J = 1, N + DWORK( J ) = DWORK( J ) + TC + 80 CONTINUE +C + DO 90 I = 1, L + DWORK( I+KW1 ) = DWORK( I+KW1 ) + T + 90 CONTINUE +C +C Apply matrix to vector. +C + DO 110 I = 1, L + KOUNT = 0 + SUM = ZERO + DO 100 J = 1, N + IF( ABS( A( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( J ) + END IF + IF( ABS( E( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( J ) + END IF + 100 CONTINUE + IF( WITHB ) THEN + J = IDAMAX( M, B( I, 1 ), LDB ) + IF( ABS( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 + END IF + DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM + 110 CONTINUE +C + DO 130 J = 1, N + KOUNT = 0 + SUM = ZERO + DO 120 I = 1, L + IF( ABS( A( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( I+KW1 ) + END IF + IF( ABS( E( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( I+KW1 ) + END IF + 120 CONTINUE + IF( WITHC ) THEN + I = IDAMAX( P, C( 1, J ), 1 ) + IF( ABS( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 + END IF + DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM + 130 CONTINUE +C + SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + + $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) + ALPHA = GAMMA / SUM +C +C Determine correction to current iteration. +C + CMAX = ZERO + DO 140 I = 1, L + COR = ALPHA*DWORK( I+KW1 ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + LSCALE( I ) = LSCALE( I ) + COR + 140 CONTINUE +C + DO 150 J = 1, N + COR = ALPHA*DWORK( J ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + RSCALE( J ) = RSCALE( J ) + COR + 150 CONTINUE + IF( CMAX.LT.HALF ) + $ GO TO 160 +C + CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) + CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) +C + PGAMMA = GAMMA + IT = IT + 1 + IF( IT.LE.NRP2 ) + $ GO TO 50 +C +C End generalized conjugate gradient iteration. +C + 160 CONTINUE + SFMIN = DLAMCH( 'Safe minimum' ) + SFMAX = ONE / SFMIN + LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) + LSFMAX = INT( LOG10( SFMAX ) / BASL ) +C +C Compute left diagonal scaling matrix. +C + DO 170 I = 1, L + IRAB = IDAMAX( N, A( I, 1 ), LDA ) + RAB = ABS( A( I, IRAB ) ) + IRAB = IDAMAX( N, E( I, 1 ), LDE ) + RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) + IF( WITHB ) THEN + IRAB = IDAMAX( M, B( I, 1 ), LDB ) + RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) + END IF + LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) + IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) + IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) + LSCALE( I ) = SCLFAC**IR + 170 CONTINUE +C +C Compute right diagonal scaling matrix. +C + DO 180 J = 1, N + ICAB = IDAMAX( L, A( 1, J ), 1 ) + CAB = ABS( A( ICAB, J ) ) + ICAB = IDAMAX( L, E( 1, J ), 1 ) + CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) + IF( WITHC ) THEN + ICAB = IDAMAX( P, C( 1, J ), 1 ) + CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) + END IF + LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) + JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) + JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) + RSCALE( J ) = SCLFAC**JC + 180 CONTINUE +C +C Row scaling of matrices A, E and B. +C + DO 190 I = 1, L + CALL DSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) + CALL DSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) + IF( WITHB ) + $ CALL DSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) + 190 CONTINUE +C +C Column scaling of matrices A, E and C. +C + DO 200 J = 1, N + CALL DSCAL( L, RSCALE( J ), A( 1, J ), 1 ) + CALL DSCAL( L, RSCALE( J ), E( 1, J ), 1 ) + IF( WITHC ) + $ CALL DSCAL( P, RSCALE( J ), C( 1, J ), 1 ) + 200 CONTINUE +C + RETURN +C *** Last line of TG01AD *** + END diff --git a/mex/sources/libslicot/TG01AZ.f b/mex/sources/libslicot/TG01AZ.f new file mode 100644 index 000000000..2c0bb3bcf --- /dev/null +++ b/mex/sources/libslicot/TG01AZ.f @@ -0,0 +1,523 @@ + SUBROUTINE TG01AZ( JOB, L, N, M, P, THRESH, A, LDA, E, LDE, + $ B, LDB, C, LDC, LSCALE, RSCALE, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To balance the matrices of the system pencil +C +C S = ( A B ) - lambda ( E 0 ) := Q - lambda Z, +C ( C 0 ) ( 0 0 ) +C +C corresponding to the descriptor triple (A-lambda E,B,C), +C by balancing. This involves diagonal similarity transformations +C (Dl*A*Dr - lambda Dl*E*Dr, Dl*B, C*Dr) applied to the system +C (A-lambda E,B,C) to make the rows and columns of system pencil +C matrices +C +C diag(Dl,I) * S * diag(Dr,I) +C +C as close in norm as possible. Balancing may reduce the 1-norms +C of the matrices of the system pencil S. +C +C The balancing can be performed optionally on the following +C particular system pencils +C +C S = A-lambda E, +C +C S = ( A-lambda E B ), or +C +C S = ( A-lambda E ). +C ( C ) +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates which matrices are involved in balancing, as +C follows: +C = 'A': All matrices are involved in balancing; +C = 'B': B, A and E matrices are involved in balancing; +C = 'C': C, A and E matrices are involved in balancing; +C = 'N': B and C matrices are not involved in balancing. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C THRESH (input) DOUBLE PRECISION +C Threshold value for magnitude of elements: +C elements with magnitude less than or equal to +C THRESH are ignored for balancing. THRESH >= 0. +C The magnitude is computed as the sum of the absolute +C values of the real and imaginary parts. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the balanced matrix Dl*A*Dr. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) COMPLEX*16 array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the balanced matrix Dl*E*Dr. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, if M > 0, the leading L-by-M part of this array +C contains the balanced matrix Dl*B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the balanced matrix C*Dr. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C LSCALE (output) DOUBLE PRECISION array, dimension (L) +C The scaling factors applied to S from left. If Dl(j) is +C the scaling factor applied to row j, then +C SCALE(j) = Dl(j), for j = 1,...,L. +C +C RSCALE (output) DOUBLE PRECISION array, dimension (N) +C The scaling factors applied to S from right. If Dr(j) is +C the scaling factor applied to column j, then +C SCALE(j) = Dr(j), for j = 1,...,N. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (3*(L+N)) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C Balancing consists of applying a diagonal similarity +C transformation +C -1 +C diag(Dl,I) * S * diag(Dr,I) +C +C to make the 1-norms of each row of the first L rows of S and its +C corresponding N columns nearly equal. +C +C Information about the diagonal matrices Dl and Dr are returned in +C the vectors LSCALE and RSCALE, respectively. +C +C REFERENCES +C +C [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C [2] R.C. Ward, R. C. +C Balancing the generalized eigenvalue problem. +C SIAM J. Sci. Stat. Comp. 2 (1981), 141-152. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Balancing, eigenvalue, matrix algebra, matrix operations, +C similarity transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION HALF, ONE, ZERO + PARAMETER ( HALF = 0.5D+0, ONE = 1.0D+0, ZERO = 0.0D+0 ) + DOUBLE PRECISION SCLFAC, THREE + PARAMETER ( SCLFAC = 1.0D+1, THREE = 3.0D+0 ) +C .. Scalar Arguments .. + CHARACTER JOB + INTEGER INFO, L, LDA, LDB, LDC, LDE, M, N, P + DOUBLE PRECISION THRESH +C .. Array Arguments .. + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ E( LDE, * ) + DOUBLE PRECISION DWORK( * ), LSCALE( * ), RSCALE( * ) +C .. Local Scalars .. + LOGICAL WITHB, WITHC + INTEGER I, ICAB, IR, IRAB, IT, J, JC, KOUNT, KW1, KW2, + $ KW3, KW4, KW5, LCAB, LRAB, LSFMAX, LSFMIN, + $ NRP2 + DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2, + $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX, + $ SFMIN, SUM, T, TA, TB, TC, TE + COMPLEX*16 CDUM +C .. Local Arrays .. + DOUBLE PRECISION DUM( 1 ) +C .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DDOT, DLAMCH + EXTERNAL DDOT, DLAMCH, IZAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSCAL, XERBLA, ZDSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, INT, LOG10, MAX, MIN, SIGN +C .. +C .. Statement Functions .. + DOUBLE PRECISION CABS1 +C .. +C .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +C +C .. Executable Statements .. +C +C Test the input parameters. +C + INFO = 0 + WITHB = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'B' ) + WITHC = LSAME( JOB, 'A' ) .OR. LSAME( JOB, 'C' ) +C + IF( .NOT.WITHB .AND. .NOT.WITHC .AND. .NOT.LSAME( JOB, 'N' ) ) + $ THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( THRESH.LT.ZERO ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01AZ', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DUM( 1 ) = ONE + IF( L.GT.0 ) THEN + CALL DCOPY( L, DUM, 0, LSCALE, 1 ) + ELSE IF( N.GT.0 ) THEN + CALL DCOPY( N, DUM, 0, RSCALE, 1 ) + END IF + RETURN + END IF +C +C Initialize balancing and allocate work storage. +C + KW1 = N + KW2 = KW1 + L + KW3 = KW2 + L + KW4 = KW3 + N + KW5 = KW4 + L + DUM( 1 ) = ZERO + CALL DCOPY( L, DUM, 0, LSCALE, 1 ) + CALL DCOPY( N, DUM, 0, RSCALE, 1 ) + CALL DCOPY( 3*(L+N), DUM, 0, DWORK, 1 ) +C +C Compute right side vector in resulting linear equations. +C + BASL = LOG10( SCLFAC ) + DO 20 I = 1, L + DO 10 J = 1, N + TE = CABS1( E( I, J ) ) + TA = CABS1( A( I, J ) ) + IF( TA.GT.THRESH ) THEN + TA = LOG10( TA ) / BASL + ELSE + TA = ZERO + END IF + IF( TE.GT.THRESH ) THEN + TE = LOG10( TE ) / BASL + ELSE + TE = ZERO + END IF + DWORK( I+KW4 ) = DWORK( I+KW4 ) - TA - TE + DWORK( J+KW5 ) = DWORK( J+KW5 ) - TA - TE + 10 CONTINUE + 20 CONTINUE +C + IF( M.EQ.0 ) THEN + WITHB = .FALSE. + TB = ZERO + END IF + IF( P.EQ.0 ) THEN + WITHC = .FALSE. + TC = ZERO + END IF +C + IF( WITHB ) THEN + DO 30 I = 1, L + J = IZAMAX( M, B( I, 1 ), LDB ) + TB = CABS1( B( I, J ) ) + IF( TB.GT.THRESH ) THEN + TB = LOG10( TB ) / BASL + DWORK( I+KW4 ) = DWORK( I+KW4 ) - TB + END IF + 30 CONTINUE + END IF +C + IF( WITHC ) THEN + DO 40 J = 1, N + I = IZAMAX( P, C( 1, J ), 1 ) + TC = CABS1( C( I, J ) ) + IF( TC.GT.THRESH ) THEN + TC = LOG10( TC ) / BASL + DWORK( J+KW5 ) = DWORK( J+KW5 ) - TC + END IF + 40 CONTINUE + END IF +C + COEF = ONE / DBLE( L+N ) + COEF2 = COEF*COEF + COEF5 = HALF*COEF2 + NRP2 = MAX( L, N ) + 2 + BETA = ZERO + IT = 1 +C +C Start generalized conjugate gradient iteration. +C + 50 CONTINUE +C + GAMMA = DDOT( L, DWORK( 1+KW4 ), 1, DWORK( 1+KW4 ), 1 ) + + $ DDOT( N, DWORK( 1+KW5 ), 1, DWORK( 1+KW5 ), 1 ) +C + EW = ZERO + DO 60 I = 1, L + EW = EW + DWORK( I+KW4 ) + 60 CONTINUE +C + EWC = ZERO + DO 70 I = 1, N + EWC = EWC + DWORK( I+KW5 ) + 70 CONTINUE +C + GAMMA = COEF*GAMMA - COEF2*( EW**2 + EWC**2 ) - + $ COEF5*( EW - EWC )**2 + IF( GAMMA.EQ.ZERO ) + $ GO TO 160 + IF( IT.NE.1 ) + $ BETA = GAMMA / PGAMMA + T = COEF5*( EWC - THREE*EW ) + TC = COEF5*( EW - THREE*EWC ) +C + CALL DSCAL( N+L, BETA, DWORK, 1 ) +C + CALL DAXPY( L, COEF, DWORK( 1+KW4 ), 1, DWORK( 1+KW1 ), 1 ) + CALL DAXPY( N, COEF, DWORK( 1+KW5 ), 1, DWORK, 1 ) +C + DO 80 J = 1, N + DWORK( J ) = DWORK( J ) + TC + 80 CONTINUE +C + DO 90 I = 1, L + DWORK( I+KW1 ) = DWORK( I+KW1 ) + T + 90 CONTINUE +C +C Apply matrix to vector. +C + DO 110 I = 1, L + KOUNT = 0 + SUM = ZERO + DO 100 J = 1, N + IF( CABS1( A( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( J ) + END IF + IF( CABS1( E( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( J ) + END IF + 100 CONTINUE + IF( WITHB ) THEN + J = IZAMAX( M, B( I, 1 ), LDB ) + IF( CABS1( B( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 + END IF + DWORK( I+KW2 ) = DBLE( KOUNT )*DWORK( I+KW1 ) + SUM + 110 CONTINUE +C + DO 130 J = 1, N + KOUNT = 0 + SUM = ZERO + DO 120 I = 1, L + IF( CABS1( A( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( I+KW1 ) + END IF + IF( CABS1( E( I, J ) ).GT.THRESH ) THEN + KOUNT = KOUNT + 1 + SUM = SUM + DWORK( I+KW1 ) + END IF + 120 CONTINUE + IF( WITHC ) THEN + I = IZAMAX( P, C( 1, J ), 1 ) + IF( CABS1( C( I, J ) ).GT.THRESH ) KOUNT = KOUNT + 1 + END IF + DWORK( J+KW3 ) = DBLE( KOUNT )*DWORK( J ) + SUM + 130 CONTINUE +C + SUM = DDOT( L, DWORK( 1+KW1 ), 1, DWORK( 1+KW2 ), 1 ) + + $ DDOT( N, DWORK, 1, DWORK( 1+KW3 ), 1 ) + ALPHA = GAMMA / SUM +C +C Determine correction to current iteration. +C + CMAX = ZERO + DO 140 I = 1, L + COR = ALPHA*DWORK( I+KW1 ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + LSCALE( I ) = LSCALE( I ) + COR + 140 CONTINUE +C + DO 150 J = 1, N + COR = ALPHA*DWORK( J ) + IF( ABS( COR ).GT.CMAX ) + $ CMAX = ABS( COR ) + RSCALE( J ) = RSCALE( J ) + COR + 150 CONTINUE + IF( CMAX.LT.HALF ) + $ GO TO 160 +C + CALL DAXPY( L, -ALPHA, DWORK( 1+KW2 ), 1, DWORK( 1+KW4 ), 1 ) + CALL DAXPY( N, -ALPHA, DWORK( 1+KW3 ), 1, DWORK( 1+KW5 ), 1 ) +C + PGAMMA = GAMMA + IT = IT + 1 + IF( IT.LE.NRP2 ) + $ GO TO 50 +C +C End generalized conjugate gradient iteration. +C + 160 CONTINUE + SFMIN = DLAMCH( 'Safe minimum' ) + SFMAX = ONE / SFMIN + LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE ) + LSFMAX = INT( LOG10( SFMAX ) / BASL ) +C +C Compute left diagonal scaling matrix. +C + DO 170 I = 1, L + IRAB = IZAMAX( N, A( I, 1 ), LDA ) + RAB = ABS( A( I, IRAB ) ) + IRAB = IZAMAX( N, E( I, 1 ), LDE ) + RAB = MAX( RAB, ABS( E( I, IRAB ) ) ) + IF( WITHB ) THEN + IRAB = IZAMAX( M, B( I, 1 ), LDB ) + RAB = MAX( RAB, ABS( B( I, IRAB ) ) ) + END IF + LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE ) + IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) ) + IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB ) + LSCALE( I ) = SCLFAC**IR + 170 CONTINUE +C +C Compute right diagonal scaling matrix. +C + DO 180 J = 1, N + ICAB = IZAMAX( L, A( 1, J ), 1 ) + CAB = ABS( A( ICAB, J ) ) + ICAB = IZAMAX( L, E( 1, J ), 1 ) + CAB = MAX( CAB, ABS( E( ICAB, J ) ) ) + IF( WITHC ) THEN + ICAB = IZAMAX( P, C( 1, J ), 1 ) + CAB = MAX( CAB, ABS( C( ICAB, J ) ) ) + END IF + LCAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE ) + JC = RSCALE( J ) + SIGN( HALF, RSCALE( J ) ) + JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB ) + RSCALE( J ) = SCLFAC**JC + 180 CONTINUE +C +C Row scaling of matrices A, E and B. +C + DO 190 I = 1, L + CALL ZDSCAL( N, LSCALE( I ), A( I, 1 ), LDA ) + CALL ZDSCAL( N, LSCALE( I ), E( I, 1 ), LDE ) + IF( WITHB ) + $ CALL ZDSCAL( M, LSCALE( I ), B( I, 1 ), LDB ) + 190 CONTINUE +C +C Column scaling of matrices A, E and C. +C + DO 200 J = 1, N + CALL ZDSCAL( L, RSCALE( J ), A( 1, J ), 1 ) + CALL ZDSCAL( L, RSCALE( J ), E( 1, J ), 1 ) + IF( WITHC ) + $ CALL ZDSCAL( P, RSCALE( J ), C( 1, J ), 1 ) + 200 CONTINUE +C + RETURN +C *** Last line of TG01AZ *** + END diff --git a/mex/sources/libslicot/TG01BD.f b/mex/sources/libslicot/TG01BD.f new file mode 100644 index 000000000..3a0681e5e --- /dev/null +++ b/mex/sources/libslicot/TG01BD.f @@ -0,0 +1,434 @@ + SUBROUTINE TG01BD( JOBE, COMPQ, COMPZ, N, M, P, ILO, IHI, A, LDA, + $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the matrices A and E of the system pencil +C +C S = ( A B ) - lambda ( E 0 ) , +C ( C 0 ) ( 0 0 ) +C +C corresponding to the descriptor triple (A-lambda E,B,C), +C to generalized upper Hessenberg form using orthogonal +C transformations, +C +C Q' * A * Z = H, Q' * E * Z = T, +C +C where H is upper Hessenberg, T is upper triangular, Q and Z +C are orthogonal, and ' means transpose. The corresponding +C transformations, written compactly as diag(Q',I) * S * diag(Z,I), +C are also applied to B and C, getting Q' * B and C * Z. +C +C The orthogonal matrices Q and Z are determined as products of +C Givens rotations. They may either be formed explicitly, or they +C may be postmultiplied into input matrices Q1 and Z1, so that +C +C Q1 * A * Z1' = (Q1*Q) * H * (Z1*Z)' +C Q1 * E * Z1' = (Q1*Q) * T * (Z1*Z)'. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBE CHARACTER*1 +C Specifies whether E is a general square or an upper +C triangular matrix, as follows: +C = 'G': E is a general square matrix; +C = 'U': E is an upper triangular matrix. +C +C COMPQ CHARACTER*1 +C Indicates what should be done with matrix Q, as follows: +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'V': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C Indicates what should be done with matrix Z, as follows: +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'V': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the matrices A, E, and the number of rows of +C the matrix B. N >= 0. +C +C M (input) INTEGER +C The number of columns of the matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of the matrix C. P >= 0. +C +C ILO (input) INTEGER +C IHI (input) INTEGER +C It is assumed that A and E are already upper triangular in +C rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI could +C normally be set by a previous call to LAPACK Library +C routine DGGBAL; otherwise they should be set to 1 and N, +C respectively. +C 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. +C If JOBE = 'U', the matrix E is assumed upper triangular. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the upper Hessenberg matrix H = Q' * A * Z. The elements +C below the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the descriptor matrix E. If JOBE = 'U', this +C matrix is assumed upper triangular. +C On exit, the leading N-by-N part of this array contains +C the upper triangular matrix T = Q' * E * Z. The elements +C below the diagonal are set to zero. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input/state matrix B. +C On exit, if M > 0, the leading N-by-M part of this array +C contains the transformed matrix Q' * B. +C The array B is not referenced if M = 0. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N) if M > 0; LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, if P > 0, the leading P-by-N part of this array +C contains the transformed matrix C * Z. +C The array C is not referenced if P = 0. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C If COMPQ = 'N': Q is not referenced; +C If COMPQ = 'I': on entry, Q need not be set, and on exit +C it contains the orthogonal matrix Q, +C where Q' is the product of the Givens +C transformations which are applied to A, +C E, and B on the left; +C If COMPQ = 'V': on entry, Q must contain an orthogonal +C matrix Q1, and on exit this is +C overwritten by Q1*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,N), if COMPQ = 'I' or 'V'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced; +C If COMPZ = 'I': on entry, Z need not be set, and on exit +C it contains the orthogonal matrix Z, +C which is the product of the Givens +C transformations applied to A, E, and C +C on the right; +C If COMPZ = 'V': on entry, Z must contain an orthogonal +C matrix Z1, and on exit this is +C overwritten by Z1*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'I' or 'V'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) contains the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of the array DWORK. +C LDWORK >= 1, if JOBE = 'U'; +C LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)), if JOBE = 'G', where +C NI = N+1-ILO, if COMPQ = 'N', and NI = N, otherwise. +C For good performance, if JOBE = 'G', LDWORK must generally +C be larger, LDWORK >= MAX(1,IHI+1-ILO+MAX(NI,M)*NB), where +C NB is the optimal block size. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit. +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C First, this routine computes the QR factorization of E and applies +C the transformations to A, B, and possibly Q. Then, the routine +C reduces A to upper Hessenberg form, preserving E triangular, by +C an unblocked reduction [1], using two sequences of plane rotations +C applied alternately from the left and from the right. The +C corresponding transformations may be accumulated and/or applied +C to the matrices B and C. If JOBE = 'U', the initial reduction of E +C to upper triangular form is skipped. +C +C This routine is a modification and extension of the LAPACK Library +C routine DGGHRD [2]. +C +C REFERENCES +C +C [1] Golub, G.H. and van Loan, C.F. +C Matrix Computations. Third Edition. +C M. D. Johns Hopkins University Press, Baltimore, 1996. +C +C [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J., +C Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A., +C Ostrouchov, S., and Sorensen, D. +C LAPACK Users' Guide: Second Edition. +C SIAM, Philadelphia, 1995. +C +C CONTRIBUTOR +C +C D. Sima, University of Bucharest, May 2001. +C V. Sima, Research Institute for Informatics, Bucharest, May 2001. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Eigenvalue, matrix algebra, matrix operations, similarity +C transformation. +C +C ********************************************************************* +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBE + INTEGER IHI, ILO, INFO, LDA, LDB, LDC, LDE, LDQ, + $ LDWORK, LDZ, M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL ILQ, ILZ, INQ, INZ, UPPER, WITHB, WITHC + INTEGER IERR, ITAU, IWRK, JCOL, JROW, MAXWRK, MINWRK + DOUBLE PRECISION CS, S, TEMP +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEQRF, DLARTG, DLASET, DORMQR, DROT, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX +C +C .. Executable Statements .. +C +C Test the input scalar parameters. +C + UPPER = LSAME( JOBE, 'U' ) + INQ = LSAME( COMPQ, 'I' ) + ILQ = LSAME( COMPQ, 'V' ) .OR. INQ + INZ = LSAME( COMPZ, 'I' ) + ILZ = LSAME( COMPZ, 'V' ) .OR. INZ + WITHB = M.GT.0 + WITHC = P.GT.0 +C + INFO = 0 + IF( .NOT.( UPPER .OR. LSAME( JOBE, 'G' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ILQ .OR. LSAME( COMPQ, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( .NOT.( ILZ .OR. LSAME( COMPZ, 'N' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( ILO.LT.1 ) THEN + INFO = -7 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( ( WITHB .AND. LDB.LT.N ) .OR. LDB.LT.1 ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -18 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -20 + ELSE + JROW = IHI + 1 - ILO + JCOL = N + 1 - ILO + IF( UPPER ) THEN + MINWRK = 1 + MAXWRK = 1 + ELSE + IF( ILQ ) THEN + MINWRK = N + ELSE + MINWRK = JCOL + END IF + MINWRK = MAX( 1, JROW + MAX( MINWRK, M ) ) + END IF + IF( LDWORK.LT.MINWRK ) + $ INFO = -22 + END IF +C + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01BD', -INFO ) + RETURN + END IF +C +C Initialize Q and Z if desired. +C + IF( INQ ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) + IF( INZ ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + IF( N.LE.1 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C + IF( .NOT.UPPER ) THEN +C +C Reduce E to triangular form (QR decomposition of E). +C +C (Note: Comments in the code beginning "Workspace:" describe the +C minimal amount of real workspace needed at that point in the +C code, as well as the preferred amount for good performance. +C NB refers to the optimal block size for the immediately +C following subroutine, as returned by ILAENV.) +C +C Workspace: need IHI+1-ILO+N+1-ILO; +C prefer IHI+1-ILO+(N+1-ILO)*NB. +C + ITAU = 1 + IWRK = ITAU + JROW + CALL DGEQRF( JROW, JCOL, E( ILO, ILO ), LDE, DWORK( ITAU ), + $ DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MINWRK ) +C +C Apply the orthogonal transformation to matrices A, B, and Q. +C Workspace: need IHI+1-ILO+N+1-ILO; +C prefer IHI+1-ILO+(N+1-ILO)*NB. +C + CALL DORMQR( 'Left', 'Transpose', JROW, JCOL, JROW, + $ E( ILO, ILO ), LDE, DWORK( ITAU ), A( ILO, ILO ), + $ LDA, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) +C + IF ( WITHB ) THEN +C +C Workspace: need IHI+1-ILO+M; +C prefer IHI+1-ILO+M*NB. +C + CALL DORMQR( 'Left', 'Transpose', JROW, M, JROW, + $ E( ILO, ILO ), LDE, DWORK( ITAU ), B( ILO, 1 ), + $ LDB, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + END IF +C + IF( ILQ ) THEN +C +C Workspace: need IHI+1-ILO+N; +C prefer IHI+1-ILO+N*NB. +C + CALL DORMQR( 'Right', 'No Transpose', N, JROW, JROW, + $ E( ILO, ILO ), LDE, DWORK( ITAU ), Q( 1, ILO ), + $ LDQ, DWORK( IWRK ), LDWORK-IWRK+1, IERR ) + MAXWRK = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, MAXWRK ) + END IF + END IF +C +C Zero out lower triangle of E. +C + IF( JROW.GT.1 ) + $ CALL DLASET( 'Lower', JROW-1, JROW-1, ZERO, ZERO, + $ E( ILO+1, ILO ), LDE ) +C +C Reduce A and E and apply the transformations to B, C, Q and Z. +C + DO 20 JCOL = ILO, IHI - 2 +C + DO 10 JROW = IHI, JCOL + 2, -1 +C +C Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL). +C + TEMP = A( JROW-1, JCOL ) + CALL DLARTG( TEMP, A( JROW, JCOL ), CS, S, + $ A( JROW-1, JCOL ) ) + A( JROW, JCOL ) = ZERO + CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA, + $ A( JROW, JCOL+1 ), LDA, CS, S ) + CALL DROT( N+2-JROW, E( JROW-1, JROW-1 ), LDE, + $ E( JROW, JROW-1 ), LDE, CS, S ) + IF( WITHB ) + $ CALL DROT( M, B( JROW-1, 1 ), LDB, B( JROW, 1 ), LDB, + $ CS, S ) + IF( ILQ ) + $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, CS, S ) +C +C Step 2: rotate columns JROW, JROW-1 to kill E(JROW,JROW-1). +C + TEMP = E( JROW, JROW ) + CALL DLARTG( TEMP, E( JROW, JROW-1 ), CS, S, + $ E( JROW, JROW ) ) + E( JROW, JROW-1 ) = ZERO + CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, CS, S ) + CALL DROT( JROW-1, E( 1, JROW ), 1, E( 1, JROW-1 ), 1, CS, + $ S ) + IF( WITHC ) + $ CALL DROT( P, C( 1, JROW ), 1, C( 1, JROW-1 ), 1, CS, S ) + IF( ILZ ) + $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, CS, S ) + 10 CONTINUE +C + 20 CONTINUE +C + DWORK( 1 ) = MAXWRK + RETURN +C *** Last line of TG01BD *** + END diff --git a/mex/sources/libslicot/TG01CD.f b/mex/sources/libslicot/TG01CD.f new file mode 100644 index 000000000..1ce07b1e4 --- /dev/null +++ b/mex/sources/libslicot/TG01CD.f @@ -0,0 +1,292 @@ + SUBROUTINE TG01CD( COMPQ, L, N, M, A, LDA, E, LDE, B, LDB, Q, LDQ, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the descriptor system pair (A-lambda E,B) to the +C QR-coordinate form by computing an orthogonal transformation +C matrix Q such that the transformed descriptor system pair +C (Q'*A-lambda Q'*E, Q'*B) has the descriptor matrix Q'*E +C in an upper trapezoidal form. +C The left orthogonal transformations performed to reduce E +C can be optionally accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A and E. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*A. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*E in upper trapezoidal form, +C i.e. +C +C ( E11 ) +C Q'*E = ( ) , if L >= N , +C ( 0 ) +C or +C +C Q'*E = ( E11 E12 ), if L < N , +C +C where E11 is an MIN(L,N)-by-MIN(L,N) upper triangular +C matrix. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, the leading L-by-M part of this array contains +C the transformed matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of Householder +C transformations which are applied to A, +C E, and B on the left. +C If COMPQ = 'U': on entry, the leading L-by-L part of this +C array must contain an orthogonal matrix +C Q1; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix +C Q1*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)). +C For optimum performance +C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,M)*NB), +C where NB is the optimal blocksize. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes the QR factorization of E to reduce it +C to the upper trapezoidal form. +C +C The transformations are also applied to the rest of system +C matrices +C +C A <- Q' * A , B <- Q' * B. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*L*N ) floating point operations. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSQR. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C May 2003. +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ + INTEGER INFO, L, LDA, LDB, LDE, LDQ, LDWORK, M, N +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DWORK( * ), + $ E( LDE, * ), Q( LDQ, * ) +C .. Local Scalars .. + LOGICAL ILQ + INTEGER ICOMPQ, LN, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGEQRF, DLASET, DORMQR, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Test the input parameters. +C + INFO = 0 + WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, M ) ) + IF( ICOMPQ.EQ.0 ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -6 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -10 + ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.WRKOPT ) THEN + INFO = -14 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01CD', -INFO ) + RETURN + END IF +C +C Initialize Q if necessary. +C + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C + LN = MIN( L, N ) +C +C Compute the QR decomposition of E. +C +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DGEQRF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C Apply transformation on the rest of matrices. +C +C A <-- Q' * A. +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', L, N, LN, E, LDE, DWORK, + $ A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C B <-- Q' * B. +C Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF ( M.GT.0 ) THEN + CALL DORMQR( 'Left', 'Transpose', L, M, LN, E, LDE, DWORK, + $ B, LDB, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) + END IF +C +C Q <-- Q1 * Q. +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) THEN + CALL DORMQR( 'Right', 'No Transpose', L, L, LN, E, LDE, DWORK, + $ Q, LDQ, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) + END IF +C +C Set lower triangle of E to zero. +C + IF( L.GE.2 ) + $ CALL DLASET( 'Lower', L-1, LN, ZERO, ZERO, E( 2, 1 ), LDE ) +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01CD *** + END diff --git a/mex/sources/libslicot/TG01DD.f b/mex/sources/libslicot/TG01DD.f new file mode 100644 index 000000000..cac8704d8 --- /dev/null +++ b/mex/sources/libslicot/TG01DD.f @@ -0,0 +1,295 @@ + SUBROUTINE TG01DD( COMPZ, L, N, P, A, LDA, E, LDE, C, LDC, Z, LDZ, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the descriptor system pair (C,A-lambda E) to the +C RQ-coordinate form by computing an orthogonal transformation +C matrix Z such that the transformed descriptor system pair +C (C*Z,A*Z-lambda E*Z) has the descriptor matrix E*Z in an upper +C trapezoidal form. +C The right orthogonal transformations performed to reduce E can +C be optionally accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix A*Z. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix E*Z in upper trapezoidal form, +C i.e. +C +C ( E11 ) +C E*Z = ( ) , if L >= N , +C ( R ) +C or +C +C E*Z = ( 0 R ), if L < N , +C +C where R is an MIN(L,N)-by-MIN(L,N) upper triangular +C matrix. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of Householder +C transformations applied to A, E, and C +C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Z1; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Z1*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)). +C For optimum performance +C LWORK >= MAX(1, MIN(L,N) + MAX(L,N,P)*NB), +C where NB is the optimal blocksize. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes the RQ factorization of E to reduce it +C the upper trapezoidal form. +C +C The transformations are also applied to the rest of system +C matrices +C +C A <- A * Z, C <- C * Z. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*N*N ) floating point operations. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSRQ. +C +C REVISIONS +C +C July 1999, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, L, LDA, LDC, LDE, LDWORK, LDZ, N, P +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), DWORK( * ), + $ E( LDE, * ), Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL ILZ + INTEGER ICOMPZ, LN, WRKOPT +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DGERQF, DLASET, DORMRQ, XERBLA +C .. Intrinsic Functions .. + INTRINSIC INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +C +C Test the input parameters. +C + INFO = 0 + WRKOPT = MAX( 1, MIN( L, N ) + MAX( L, N, P ) ) + IF( ICOMPZ.EQ.0 ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( P.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -6 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -10 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -12 + ELSE IF( LDWORK.LT.WRKOPT ) THEN + INFO = -14 + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'TG01DD', -INFO ) + RETURN + END IF +C +C Initialize Q if necessary. +C + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DWORK( 1 ) = ONE + RETURN + END IF +C + LN = MIN( L, N ) +C +C Compute the RQ decomposition of E, E = R*Z. +C +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + CALL DGERQF( L, N, E, LDE, DWORK, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C Apply transformation on the rest of matrices. +C +C A <-- A * Z'. +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + CALL DORMRQ( 'Right', 'Transpose', L, N, LN, E( L-LN+1,1 ), LDE, + $ DWORK, A, LDA, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C C <-- C * Z'. +C Workspace: need MIN(L,N) + P; +C prefer MIN(L,N) + P*NB. +C + CALL DORMRQ( 'Right', 'Transpose', P, N, LN, E( L-LN+1,1 ), LDE, + $ DWORK, C, LDC, DWORK( LN+1 ), LDWORK-LN, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) +C +C Z <-- Z1 * Z'. +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + IF( ILZ ) THEN + CALL DORMRQ( 'Right', 'Transpose', N, N, LN, E( L-LN+1,1 ), + $ LDE, DWORK, Z, LDZ, DWORK( LN+1 ), LDWORK-LN, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK( LN+1 ) ) + LN ) + END IF +C +C Set lower triangle of E to zero. +C + IF( L.LT.N ) THEN + CALL DLASET( 'Full', L, N-L, ZERO, ZERO, E, LDE ) + IF( L.GE.2 ) CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, + $ E( 2, N-L+1 ), LDE ) + ELSE + IF( N.GE.2 ) CALL DLASET( 'Lower', N-1, N, ZERO, ZERO, + $ E( L-N+2, 1 ), LDE ) + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01DD *** + END diff --git a/mex/sources/libslicot/TG01ED.f b/mex/sources/libslicot/TG01ED.f new file mode 100644 index 000000000..1fe8e8bba --- /dev/null +++ b/mex/sources/libslicot/TG01ED.f @@ -0,0 +1,793 @@ + SUBROUTINE TG01ED( JOBA, L, N, M, P, A, LDA, E, LDE, B, LDB, + $ C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, TOL, + $ DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for the descriptor system (A-lambda E,B,C) +C the orthogonal transformation matrices Q and Z such that the +C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is in an +C SVD (singular value decomposition) coordinate form with +C the system matrices Q'*A*Z and Q'*E*Z in the form +C +C ( A11 A12 ) ( Er 0 ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , +C ( A21 A22 ) ( 0 0 ) +C +C where Er is an invertible diagonal matrix having on the diagonal +C the decreasingly ordered nonzero singular values of E. +C Optionally, the A22 matrix can be further reduced to the +C SVD form +C +C ( Ar 0 ) +C A22 = ( ) , +C ( 0 0 ) +C +C where Ar is an invertible diagonal matrix having on the diagonal +C the decreasingly ordered nonzero singular values of A22. +C The left and/or right orthogonal transformations performed +C to reduce E and A22 are accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBA CHARACTER*1 +C = 'N': do not reduce A22; +C = 'R': reduce A22 to an SVD form. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*A*Z. If JOBA = 'R', this matrix +C is in the form +C +C ( A11 * * ) +C Q'*A*Z = ( * Ar 0 ) , +C ( * 0 0 ) +C +C where A11 is a RANKE-by-RANKE matrix and Ar is a +C RNKA22-by-RNKA22 invertible diagonal matrix, with +C decresingly ordered positive diagonal elements. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*E*Z. +C +C ( Er 0 ) +C Q'*E*Z = ( ) , +C ( 0 0 ) +C +C where Er is a RANKE-by-RANKE invertible diagonal matrix +C having on the diagonal the decreasingly ordered positive +C singular values of E. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, the leading L-by-M part of this array contains +C the transformed matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,L) +C The leading L-by-L part of this array contains the +C orthogonal matrix Q, which is the accumulated product of +C transformations applied to A, E, and B on the left. +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= MAX(1,L). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the +C orthogonal matrix Z, which is the accumulated product of +C transformations applied to A, E, and C on the right. +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= MAX(1,N). +C +C RANKE (output) INTEGER +C The effective rank of matrix E, and thus also the order +C of the invertible diagonal submatrix Er. +C RANKE is computed as the number of singular values of E +C greater than TOL*SVEMAX, where SVEMAX is the maximum +C singular value of E. +C +C RNKA22 (output) INTEGER +C If JOBA = 'R', then RNKA22 is the effective rank of +C matrix A22, and thus also the order of the invertible +C diagonal submatrix Ar. RNKA22 is computed as the number +C of singular values of A22 greater than TOL*SVAMAX, +C where SVAMAX is an estimate of the maximum singular value +C of A. +C If JOBA = 'N', then RNKA22 is not referenced. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the rank of E +C and of A22. If TOL > 0, then singular values less than +C TOL*SVMAX are treated as zero, where SVMAX is the maximum +C singular value of E or an estimate of it for A and E. +C If TOL <= 0, the default tolerance TOLDEF = EPS*L*N is +C used instead, where EPS is the machine precision +C (see LAPACK Library routine DLAMCH). TOL < 1. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(1,MIN(L,N) + +C MAX(3*MIN(L,N)+MAX(L,N), 5*MIN(L,N), M, P)). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: the QR algorithm has failed to converge when computing +C singular value decomposition. In this case INFO +C specifies how many superdiagonals did not converge. +C This failure is not likely to occur. +C +C METHOD +C +C The routine computes the singular value decomposition (SVD) of E, +C in the form +C +C ( Er 0 ) +C E = Q * ( ) * Z' +C ( 0 0 ) +C +C and finds the largest RANKE-by-RANKE leading diagonal submatrix +C Er whose condition number is less than 1/TOL. RANKE defines thus +C the effective rank of matrix E. +C If JOBA = 'R' the same reduction is performed on A22 in the +C partitioned matrix +C +C ( A11 A12 ) +C Q'*A*Z = ( ) , +C ( A21 A22 ) +C +C to obtain it in the form +C +C ( Ar 0 ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an invertible diagonal matrix. +C +C The accumulated transformations are also applied to the rest of +C matrices +C +C B <- Q' * B, C <- C * Z. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*L*N ) floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSSV. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C Feb. 2000, Oct. 2001, May 2003. +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER JOBA + INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, + $ LDZ, M, N, P, RNKA22, RANKE + DOUBLE PRECISION TOL +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL REDA + INTEGER I, IR1, J, KW, LA22, LN, LN2, LWR, NA22, WRKOPT + DOUBLE PRECISION EPSM, SVEMAX, SVLMAX, TOLDEF +C .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, LSAME +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGEQRF, DGELQF, DGESVD, + $ DLACPY, DLASET, DORMQR, DORMLQ, DSWAP, MA02AD, + $ MB03UD, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C + REDA = LSAME( JOBA, 'R' ) +C +C Test the input parameters. +C + INFO = 0 + WRKOPT = MIN( L, N ) + + $ MAX( M, P, 3*MIN( L, N ) + MAX( L, N ), 5*MIN( L, N ) ) + IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA ) THEN + INFO = -1 + ELSE IF( L.LT.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( P.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -7 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN + INFO = -11 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -13 + ELSE IF( LDQ.LT.MAX( 1, L ) ) THEN + INFO = -15 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -17 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -20 + ELSE IF( LDWORK.LT.MAX( 1, WRKOPT ) ) THEN + INFO = -22 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01ED', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + IF( L.GT.0 ) + $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) + IF( N.GT.0 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) + DWORK(1) = ONE + RANKE = 0 + IF( REDA ) RNKA22 = 0 + RETURN + END IF +C + LN = MIN( L, N ) + EPSM = DLAMCH( 'EPSILON' ) +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance for rank determination. +C + TOLDEF = EPSM * DBLE( L*N ) + END IF +C +C Set the estimate of the maximum singular value of E to +C max(||E||,||A||) to detect negligible A or E matrices. +C + SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ) , + $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) +C +C Compute the SVD of E +C +C ( Er 0 ) +C E = Qr * ( ) * Zr' +C ( 0 0 ) +C +C Workspace: needed MIN(L,N) + MAX(3*MIN(L,N)+MAX(L,N),5*MIN(L,N)); +C prefer larger. +C + LWR = LDWORK - LN + KW = LN + 1 +C + CALL DGESVD( 'A', 'A', L, N, E, LDE, DWORK, Q, LDQ, Z, LDZ, + $ DWORK(KW), LWR, INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Determine the rank of E. +C + RANKE = 0 + IF( DWORK(1).GT.SVLMAX*EPSM ) THEN + RANKE = 1 + SVEMAX = DWORK(1) + DO 10 I = 2, LN + IF( DWORK(I).LT.SVEMAX*TOLDEF ) GO TO 20 + RANKE = RANKE + 1 + 10 CONTINUE +C + 20 CONTINUE + END IF +C +C Apply transformation on the rest of matrices. +C + IF( RANKE.GT.0 ) THEN +C +C A <-- Qr' * A * Zr. +C + CALL DGEMM( 'Transpose', 'No transpose', L, N, L, ONE, + $ Q, LDQ, A, LDA, ZERO, E, LDE ) + CALL DGEMM( 'No transpose', 'Transpose', L, N, N, ONE, + $ E, LDE, Z, LDZ, ZERO, A, LDA ) +C +C B <-- Qr' * B. +C Workspace: need L; +C prefer L*M. +C + IF( LWR.GT.L*M .AND. M.GT.0 ) THEN +C + CALL DGEMM( 'Transpose', 'No transpose', L, M, L, ONE, + $ Q, LDQ, B, LDB, ZERO, DWORK(KW), L ) + CALL DLACPY( 'Full', L, M, DWORK(KW), L, B, LDB ) + ELSE + DO 30 J = 1, M + CALL DGEMV( 'Transpose', L, L, ONE, Q, LDQ, B(1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( L, DWORK(KW), 1, B(1,J), 1 ) + 30 CONTINUE + END IF +C +C C <-- C * Zr. +C Workspace: need N; +C prefer P*N. +C + IF( LWR.GT.P*N ) THEN +C + CALL DGEMM( 'No transpose', 'Transpose', P, N, N, ONE, + $ C, LDC, Z, LDZ, ZERO, DWORK(KW), MAX( 1, P ) ) + CALL DLACPY( 'Full', P, N, DWORK(KW), MAX( 1, P ), C, LDC ) + ELSE + DO 40 I = 1, P + CALL DGEMV( 'No transpose', N, N, ONE, Z, LDZ, + $ C(I,1), LDC, ZERO, DWORK(KW), 1 ) + CALL DCOPY( N, DWORK(KW), 1, C(I,1), LDC ) + 40 CONTINUE + END IF + WRKOPT = MAX( WRKOPT, L*M, P*N ) + END IF +C +C Reduce A22 if necessary. +C + IF( REDA ) THEN + LA22 = L - RANKE + NA22 = N - RANKE + LN2 = MIN( LA22, NA22 ) + IF( LN2.EQ.0 ) THEN + IR1 = 1 + RNKA22 = 0 + ELSE +C +C Compute the SVD of A22 using a storage saving approach. +C + IR1 = RANKE + 1 + IF( LA22.GE.NA22 ) THEN +C +C Compute the QR decomposition of A22 in the form +C +C A22 = Q2 * ( R2 ) , +C ( 0 ) +C +C where R2 is upper triangular. +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DGEQRF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Apply transformation Q2 to A, B, and Q. +C +C A <--diag(I, Q2') * A +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), A(IR1,1), LDA, + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C B <-- diag(I, Q2') * B +C Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF ( M.GT.0 ) THEN + CALL DORMQR( 'Left', 'Transpose', LA22, M, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), B(IR1,1), + $ LDB, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) + END IF +C +C Q <-- Q * diag(I, Q2) +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + CALL DORMQR( 'Right', 'No transpose', L, LA22, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), Q(1,IR1), LDQ, + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Compute the SVD of the upper triangular submatrix R2 as +C +C ( Ar 0 ) +C R2 = Q2r * ( ) * Z2r' , +C ( 0 0 ) +C +C where Q2r is stored in E and Z2r' is stored in A22. +C Workspace: need MAX(1,5*MIN(L,N)); +C prefer larger. +C + CALL MB03UD( 'Vectors', 'Vectors', LN2, A(IR1,IR1), LDA, + $ E(IR1,IR1), LDE, DWORK(IR1), DWORK(KW), LWR, + $ INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Determine the rank of A22. +C + RNKA22 = 0 + IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN + RNKA22 = 1 + DO 50 I = IR1+1, LN + IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 60 + RNKA22 = RNKA22 + 1 + 50 CONTINUE +C + 60 CONTINUE + END IF +C +C Apply transformation on the rest of matrices. +C + IF( RNKA22.GT.0 ) THEN +C +C A <-- diag(I,Q2r') * A * diag(I,Zr2) +C + CALL DGEMM( 'Transpose', 'No transpose', LN2, RANKE, + $ LN2, ONE, E(IR1,IR1), LDE, A(IR1,1), LDA, + $ ZERO, E(IR1,1), LDE ) + CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, + $ A(IR1,1), LDA ) + CALL DGEMM( 'No transpose', 'Transpose', RANKE, LN2, + $ LN2, ONE, A(1,IR1), LDA, A(IR1,IR1), LDA, + $ ZERO, E(1,IR1), LDE ) + CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, + $ A(1,IR1), LDA ) +C +C B <-- diag(I,Q2r') * B +C + IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN +C + CALL DGEMM( 'Transpose', 'No transpose', LN2, M, + $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), + $ LDB, ZERO, DWORK(KW), LN2 ) + CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, + $ B(IR1,1), LDB ) + ELSE + DO 70 J = 1, M + CALL DGEMV( 'Transpose', LN2, LN2, ONE, + $ E(IR1,IR1), LDE, B( IR1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) + 70 CONTINUE + END IF +C +C C <-- C * diag(I,Zr2) +C + IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN +C + CALL DGEMM( 'No transpose', 'Transpose', P, LN2, + $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), + $ LDA, ZERO, DWORK(KW), P ) + CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, + $ C(1,IR1), LDC ) + ELSE + DO 80 I = 1, P + CALL DGEMV( 'No transpose', LN2, LN2, ONE, + $ A(IR1,IR1), LDA, C(I,IR1), LDC, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) + 80 CONTINUE + END IF +C +C Q <-- Q * diag(I, Qr2) +C + IF( LWR.GT.L*LN2 ) THEN +C + CALL DGEMM( 'No transpose', 'No transpose', L, LN2, + $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), + $ LDE, ZERO, DWORK(KW), L ) + CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, + $ Q(1,IR1), LDQ ) + ELSE + DO 90 I = 1, L + CALL DGEMV( 'Transpose', LN2, LN2, ONE, + $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) + 90 CONTINUE + END IF +C +C Z' <-- diag(I, Zr2') * Z' +C + IF( LWR.GT.N*LN2 ) THEN +C + CALL DGEMM( 'No transpose', 'No transpose', LN2, N, + $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), + $ LDZ, ZERO, DWORK(KW), LN2 ) + CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, + $ Z(IR1,1), LDZ ) + ELSE + DO 100 J = 1, N + CALL DGEMV( 'No transpose', LN2, LN2, ONE, + $ A(IR1,IR1), LDA, Z(IR1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) + 100 CONTINUE + END IF + END IF + ELSE +C +C Compute the LQ decomposition of A22 in the form +C +C A22 = ( L2 0 )* Z2 +C +C where L2 is lower triangular. +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + CALL DGELQF( LA22, NA22, A(IR1,IR1), LDA, DWORK(IR1), + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Apply transformation Z2 to A, C, and Z. +C +C A <-- A * diag(I, Z2') +C Workspace: need 2*MIN(L,N); +C prefer MIN(L,N) + MIN(L,N)*NB. +C + CALL DORMLQ( 'Right', 'Transpose', RANKE, NA22, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), A(1,IR1), LDA, + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C C <-- C * diag(I, Z2') +C Workspace: need MIN(L,N) + P; +C prefer MIN(L,N) + P*NB. +C + IF ( P.GT.0 ) THEN + CALL DORMLQ( 'Right', 'Transpose', P, NA22, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), C(1,IR1), + $ LDC, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) + END IF +C +C Z' <- diag(I, Z2) * Z' +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMLQ( 'Left', 'No transpose', NA22, N, LN2, + $ A(IR1,IR1), LDA, DWORK(IR1), Z(IR1,1), LDZ, + $ DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Compute the SVD of the lower triangular submatrix L2 as +C +C ( Ar 0 ) +C L2' = Z2r * ( ) * Q2r' +C ( 0 0 ) +C +C where Q2r' is stored in E and Z2r is stored in A22. +C Workspace: need MAX(1,5*MIN(L,N)); +C prefer larger. +C + CALL MA02AD( 'Lower', LN2, LN2, A(IR1,IR1), LDA, + $ E(IR1,IR1), LDE ) + CALL MB03UD( 'Vectors', 'Vectors', LN2, E(IR1,IR1), LDE, + $ A(IR1,IR1), LDA, DWORK(IR1), DWORK(KW), + $ LWR, INFO ) + IF( INFO.GT.0 ) + $ RETURN + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C Determine the rank of A22. +C + RNKA22 = 0 + IF( DWORK(IR1).GT.SVLMAX*EPSM ) THEN + RNKA22 = 1 + DO 110 I = IR1+1, LN + IF( DWORK(I).LE.SVLMAX*TOLDEF ) GO TO 120 + RNKA22 = RNKA22 + 1 + 110 CONTINUE +C + 120 CONTINUE + END IF +C +C Apply transformation on the rest of matrices. +C + IF( RNKA22.GT.0 ) THEN +C +C A <-- diag(I,Q2r') * A * diag(I,Zr2) +C + CALL DGEMM( 'No transpose', 'No transpose', LN2, + $ RANKE, LN2, ONE, E(IR1,IR1), LDE, + $ A(IR1,1), LDA, ZERO, E(IR1,1), LDE ) + CALL DLACPY( 'Full', LN2, RANKE, E(IR1,1), LDE, + $ A(IR1,1), LDA ) + CALL DGEMM( 'No transpose', 'No transpose', RANKE, + $ LN2, LN2, ONE, A(1,IR1), LDA, + $ A(IR1,IR1), LDA, ZERO, E(1,IR1), LDE ) + CALL DLACPY( 'Full', RANKE, LN2, E(1,IR1), LDE, + $ A(1,IR1), LDA ) +C +C B <-- diag(I,Q2r') * B +C + IF( LWR.GT.LN2*M .AND. M.GT.0 ) THEN +C + CALL DGEMM( 'No transpose', 'No transpose', LN2, M, + $ LN2, ONE, E(IR1,IR1), LDE, B(IR1,1), + $ LDB, ZERO, DWORK(KW), LN2 ) + CALL DLACPY( 'Full', LN2, M, DWORK(KW), LN2, + $ B(IR1,1), LDB ) + ELSE + DO 130 J = 1, M + CALL DGEMV( 'No transpose', LN2, LN2, ONE, + $ E(IR1,IR1), LDE, B( IR1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, B(IR1,J), 1 ) + 130 CONTINUE + END IF +C +C C <-- C * diag(I,Zr2) +C + IF( LWR.GT.P*LN2 .AND. P.GT.0 ) THEN +C + CALL DGEMM( 'No transpose', 'No transpose', P, LN2, + $ LN2, ONE, C(1,IR1), LDC, A(IR1,IR1), + $ LDA, ZERO, DWORK(KW), P ) + CALL DLACPY( 'Full', P, LN2, DWORK( KW ), P, + $ C(1,IR1), LDC ) + ELSE + DO 140 I = 1, P + CALL DGEMV( 'Transpose', LN2, LN2, ONE, + $ A(IR1,IR1), LDA, C(I,IR1), LDC, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, C(I,IR1), LDC ) + 140 CONTINUE + END IF +C +C Q <-- Q * diag(I, Qr2) +C + IF( LWR.GT.L*LN2 ) THEN +C + CALL DGEMM( 'No transpose', 'Transpose', L, LN2, + $ LN2, ONE, Q(1,IR1), LDQ, E(IR1,IR1), + $ LDE, ZERO, DWORK(KW), L ) + CALL DLACPY( 'Full', L, LN2, DWORK(KW), L, + $ Q(1,IR1), LDQ ) + ELSE + DO 150 I = 1, L + CALL DGEMV( 'No transpose', LN2, LN2, ONE, + $ E(IR1,IR1), LDE, Q(I,IR1), LDQ, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, Q(I,IR1), LDQ ) + 150 CONTINUE + END IF +C +C Z' <-- diag(I, Zr2') * Z' +C + IF( LWR.GT.N*LN2 ) THEN +C + CALL DGEMM( 'Transpose', 'No transpose', LN2, N, + $ LN2, ONE, A(IR1,IR1), LDA, Z(IR1,1), + $ LDZ, ZERO, DWORK(KW), LN2 ) + CALL DLACPY( 'Full', LN2, N, DWORK(KW), LN2, + $ Z(IR1,1), LDZ ) + ELSE + DO 160 J = 1, N + CALL DGEMV( 'Transpose', LN2, LN2, ONE, + $ A(IR1,IR1), LDA, Z(IR1,J), 1, + $ ZERO, DWORK(KW), 1 ) + CALL DCOPY( LN2, DWORK(KW), 1, Z(IR1,J), 1 ) + 160 CONTINUE + END IF + END IF + END IF + END IF + END IF +C +C Set E. +C + CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) + CALL DCOPY( RANKE, DWORK, 1, E, LDE+1 ) +C + IF( REDA ) THEN +C +C Set A22. +C + CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, A(IR1,IR1), LDA ) + CALL DCOPY( RNKA22, DWORK(IR1), 1, A(IR1,IR1), LDA+1 ) + END IF +C +C Transpose Z. +C + DO 170 I = 2, N + CALL DSWAP( I-1, Z(1,I), 1, Z(I,1), LDZ ) + 170 CONTINUE +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01ED *** + END diff --git a/mex/sources/libslicot/TG01FD.f b/mex/sources/libslicot/TG01FD.f new file mode 100644 index 000000000..c50d5fc95 --- /dev/null +++ b/mex/sources/libslicot/TG01FD.f @@ -0,0 +1,725 @@ + SUBROUTINE TG01FD( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, + $ TOL, IWORK, DWORK, LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for the descriptor system (A-lambda E,B,C) +C the orthogonal transformation matrices Q and Z such that the +C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is +C in a SVD-like coordinate form with +C +C ( A11 A12 ) ( Er 0 ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , +C ( A21 A22 ) ( 0 0 ) +C +C where Er is an upper triangular invertible matrix. +C Optionally, the A22 matrix can be further reduced to the form +C +C ( Ar X ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix, and X either a full +C or a zero matrix. +C The left and/or right orthogonal transformations performed +C to reduce E and A22 can be optionally accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C JOBA CHARACTER*1 +C = 'N': do not reduce A22; +C = 'R': reduce A22 to a SVD-like upper triangular form. +C = 'T': reduce A22 to an upper trapezoidal form. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix +C is in the form +C +C ( A11 * * ) +C Q'*A*Z = ( * Ar X ) , +C ( * 0 0 ) +C +C where A11 is a RANKE-by-RANKE matrix and Ar is a +C RNKA22-by-RNKA22 invertible upper triangular matrix. +C If JOBA = 'R' then A has the above form with X = 0. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*E*Z. +C +C ( Er 0 ) +C Q'*E*Z = ( ) , +C ( 0 0 ) +C +C where Er is a RANKE-by-RANKE upper triangular invertible +C matrix. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, the leading L-by-M part of this array contains +C the transformed matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of Householder +C transformations which are applied to A, +C E, and B on the left. +C If COMPQ = 'U': on entry, the leading L-by-L part of this +C array must contain an orthogonal matrix +C Q1; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix +C Q1*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of Householder +C transformations applied to A, E, and C +C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Z1; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Z1*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C RANKE (output) INTEGER +C The estimated rank of matrix E, and thus also the order +C of the invertible upper triangular submatrix Er. +C +C RNKA22 (output) INTEGER +C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of +C matrix A22, and thus also the order of the invertible +C upper triangular submatrix Ar. +C If JOBA = 'N', then RNKA22 is not referenced. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the rank of E +C and of A22. If the user sets TOL > 0, then the given +C value of TOL is used as a lower bound for the +C reciprocal condition numbers of leading submatrices +C of R or R22 in the QR decompositions E * P = Q * R of E +C or A22 * P22 = Q22 * R22 of A22. +C A submatrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = L*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). +C For optimal performance, LDWORK should be larger. +C +C If LDWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C DWORK array, returns this value as the first entry of +C the DWORK array, and no error message related to LDWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of E, in the form +C +C ( E11 E12 ) +C E * P = Q * ( ) +C ( 0 E22 ) +C +C and finds the largest RANKE-by-RANKE leading submatrix E11 whose +C estimated condition number is less than 1/TOL. RANKE defines thus +C the rank of matrix E. Further E22, being negligible, is set to +C zero, and an orthogonal matrix Y is determined such that +C +C ( E11 E12 ) = ( Er 0 ) * Y . +C +C The overal transformation matrix Z results as Z = P * Y' and the +C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form +C +C ( Er 0 ) ( A11 A12 ) +C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , +C ( 0 0 ) ( A21 A22 ) +C +C where Er is an upper triangular invertible matrix. +C If JOBA = 'R' the same reduction is performed on A22 to obtain it +C in the form +C +C ( Ar 0 ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix. +C If JOBA = 'T' then A22 is row compressed using the QR +C factorization with column pivoting to the form +C +C ( Ar X ) +C A22 = ( ) +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix. +C +C The transformations are also applied to the rest of system +C matrices +C +C B <- Q' * B, C <- C * Z. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*L*N ) floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSSV. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C May 2003, Jan. 2009. +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBA + INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK, + $ LDZ, M, N, P, RANKE, RNKA22 + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC + INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, + $ LH, LN, LWR, NA22, NB, WRKOPT + DOUBLE PRECISION SVLMAX, TOLDEF +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME +C .. External Subroutines .. + EXTERNAL DLASET, DORMQR, DORMRZ, DSWAP, DTZRZF, MB03OY, + $ XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF + REDA = LSAME( JOBA, 'R' ) + REDTR = LSAME( JOBA, 'T' ) + WITHB = M.GT.0 + WITHC = P.GT.0 + LQUERY = ( LDWORK.EQ.-1 ) +C +C Test the input parameters. +C + LN = MIN( L, N ) + INFO = 0 + WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) + IF( ICOMPQ.LE.0 ) THEN + INFO = -1 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. + $ .NOT.REDTR ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN + INFO = -17 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -19 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -22 + ELSE + IF( LQUERY ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LC', L, N, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + N*NB ) + IF( WITHB ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'LC', L, M, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + M*NB ) + END IF + IF( ILQ ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMQR', 'RN', L, L, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + L*NB ) + END IF + NB = ILAENV( 1, 'DGERQF', ' ', L, N, -1, -1 ) + WRKOPT = MAX( WRKOPT, LN + N*NB ) + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', L, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, L )*NB ) + IF( WITHC ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', P, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, P )*NB ) + END IF + IF( ILZ ) THEN + NB = MIN( 64, ILAENV( 1, 'DORMRQ', 'RC', N, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, N )*NB ) + END IF + ELSE IF( LDWORK.LT.WRKOPT ) THEN + INFO = -25 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01FD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + DWORK(1) = WRKOPT + RETURN + END IF +C +C Initialize Q and Z if necessary. +C + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + DWORK(1) = ONE + RANKE = 0 + IF( REDA .OR. REDTR ) RNKA22 = 0 + RETURN + END IF +C + TOLDEF = TOL + IF( TOLDEF.LE.ZERO ) THEN +C +C Use the default tolerance for rank determination. +C + TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) + END IF +C +C Set the estimate of maximum singular value of E to +C max(||E||,||A||) to detect negligible A or E matrices. +C + SVLMAX = MAX( DLANGE( 'F', L, N, E, LDE, DWORK ), + $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) +C +C Compute the rank-revealing QR decomposition of E, +C +C ( E11 E12 ) +C E * P = Qr * ( ) , +C ( 0 E22 ) +C +C and determine the rank of E using incremental condition +C estimation. +C Workspace: MIN(L,N) + 3*N - 1. +C + LWR = LDWORK - LN + KW = LN + 1 +C + CALL MB03OY( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, + $ DWORK, DWORK(KW), INFO ) +C +C Apply transformation on the rest of matrices. +C + IF( RANKE.GT.0 ) THEN +C +C A <-- Qr' * A. +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', L, N, RANKE, E, LDE, DWORK, + $ A, LDA, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) +C +C B <-- Qr' * B. +C Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF( WITHB ) THEN + CALL DORMQR( 'Left', 'Transpose', L, M, RANKE, E, LDE, + $ DWORK, B, LDB, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) + END IF +C +C Q <-- Q * Qr. +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) THEN + CALL DORMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, + $ DWORK, Q, LDQ, DWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) ) + END IF +C +C Set lower triangle of E to zero. +C + IF( L.GE.2 ) + $ CALL DLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) +C +C Compute A*P, C*P and Z*P by forward permuting the columns of +C A, C and Z based on information in IWORK. +C + DO 10 J = 1, N + IWORK(J) = -IWORK(J) + 10 CONTINUE + DO 30 I = 1, N + IF( IWORK(I).LT.0 ) THEN + J = I + IWORK(J) = -IWORK(J) + 20 CONTINUE + K = IWORK(J) + IF( IWORK(K).LT.0 ) THEN + CALL DSWAP( L, A(1,J), 1, A(1,K), 1 ) + IF( WITHC ) + $ CALL DSWAP( P, C(1,J), 1, C(1,K), 1 ) + IF( ILZ ) + $ CALL DSWAP( N, Z(1,J), 1, Z(1,K), 1 ) + IWORK(K) = -IWORK(K) + J = K + GO TO 20 + END IF + END IF + 30 CONTINUE +C +C Determine an orthogonal matrix Y such that +C +C ( E11 E12 ) = ( Er 0 ) * Y . +C +C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. +C + IF( RANKE.LT.N ) THEN +C +C Workspace: need 2*N; +C prefer N + N*NB. +C + KW = RANKE + 1 + CALL DTZRZF( RANKE, N, E, LDE, DWORK, DWORK(KW), + $ LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Workspace: need N + MAX(L,P,N); +C prefer N + MAX(L,P,N)*NB. +C + LH = N - RANKE + CALL DORMRZ( 'Right', 'Transpose', L, N, RANKE, LH, E, LDE, + $ DWORK, A, LDA, DWORK(KW), LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + IF( WITHC ) THEN + CALL DORMRZ( 'Right', 'Transpose', P, N, RANKE, LH, E, + $ LDE, DWORK, C, LDC, DWORK(KW), LDWORK-KW+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF + IF( ILZ ) THEN + CALL DORMRZ( 'Right', 'Transpose', N, N, RANKE, LH, E, + $ LDE, DWORK, Z, LDZ, DWORK(KW), LDWORK-KW+1, + $ INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF +C +C Set E12 and E22 to zero. +C + CALL DLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) + END IF + ELSE + CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) + END IF +C +C Reduce A22 if necessary. +C + IF( REDA .OR. REDTR ) THEN + LA22 = L - RANKE + NA22 = N - RANKE + IF( MIN( LA22, NA22 ).EQ.0 ) THEN + RNKA22 = 0 + ELSE +C +C Compute the rank-revealing QR decomposition of A22, +C +C ( R11 R12 ) +C A22 * P2 = Q2 * ( ) , +C ( 0 R22 ) +C +C and determine the rank of A22 using incremental +C condition estimation. +C Workspace: MIN(L,N) + 3*N - 1. +C + IR1 = RANKE + 1 + CALL MB03OY( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, + $ SVLMAX, RNKA22, SVAL, IWORK, DWORK, + $ DWORK(KW), INFO ) +C +C Apply transformation on the rest of matrices. +C + IF( RNKA22.GT.0 ) THEN +C +C A <-- diag(I, Q2') * A +C Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, RNKA22, + $ A(IR1,IR1), LDA, DWORK, A(IR1,1), LDA, + $ DWORK(KW), LWR, INFO ) +C +C B <-- diag(I, Q2') * B +C Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF ( WITHB ) + $ CALL DORMQR( 'Left', 'Transpose', LA22, M, RNKA22, + $ A(IR1,IR1), LDA, DWORK, B(IR1,1), LDB, + $ DWORK(KW), LWR, INFO ) +C +C Q <-- Q * diag(I, Q2) +C Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) + $ CALL DORMQR( 'Right', 'No transpose', L, LA22, RNKA22, + $ A(IR1,IR1), LDA, DWORK, Q(1,IR1), LDQ, + $ DWORK(KW), LWR, INFO ) +C +C Set lower triangle of A22 to zero. +C + IF( LA22.GE.2 ) + $ CALL DLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, + $ A(IR1+1,IR1), LDA ) +C +C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) +C by forward permuting the columns of A, C and Z based +C on information in IWORK. +C + DO 40 J = 1, NA22 + IWORK(J) = -IWORK(J) + 40 CONTINUE + DO 60 I = 1, NA22 + IF( IWORK(I).LT.0 ) THEN + J = I + IWORK(J) = -IWORK(J) + 50 CONTINUE + K = IWORK(J) + IF( IWORK(K).LT.0 ) THEN + CALL DSWAP( RANKE, A(1,RANKE+J), 1, + $ A(1,RANKE+K), 1 ) + IF( WITHC ) + $ CALL DSWAP( P, C(1,RANKE+J), 1, + $ C(1,RANKE+K), 1 ) + IF( ILZ ) + $ CALL DSWAP( N, Z(1,RANKE+J), 1, + $ Z(1,RANKE+K), 1 ) + IWORK(K) = -IWORK(K) + J = K + GO TO 50 + END IF + END IF + 60 CONTINUE +C + IF( REDA .AND. RNKA22.LT.NA22 ) THEN +C +C Determine an orthogonal matrix Y2 such that +C +C ( R11 R12 ) = ( Ar 0 ) * Y2 . +C +C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), +C Z <-- Z*diag(I, Y2'). +C Workspace: need 2*N. +C prefer N + N*NB. +C + KW = RANKE + 1 + CALL DTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, DWORK, + $ DWORK(KW), LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) +C +C Workspace: need N + MAX(P,N); +C prefer N + MAX(P,N)*NB. +C + LH = NA22 - RNKA22 + IF( WITHC ) THEN + CALL DORMRZ( 'Right', 'Transpose', P, N, RNKA22, + $ LH, A(IR1,IR1), LDA, DWORK, C, LDC, + $ DWORK(KW), LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF + IF( ILZ ) THEN + CALL DORMRZ( 'Right', 'Transpose', N, N, RNKA22, + $ LH, A(IR1,IR1), LDA, DWORK, Z, LDZ, + $ DWORK(KW), LDWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 ) + END IF + IRE1 = RANKE + RNKA22 + 1 +C +C Set R12 and R22 to zero. +C + CALL DLASET( 'Full', LA22, LH, ZERO, ZERO, + $ A(IR1,IRE1), LDA ) + END IF + ELSE + CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO, + $ A(IR1,IR1), LDA) + END IF + END IF + END IF +C + DWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01FD *** + END diff --git a/mex/sources/libslicot/TG01FZ.f b/mex/sources/libslicot/TG01FZ.f new file mode 100644 index 000000000..5d8f59509 --- /dev/null +++ b/mex/sources/libslicot/TG01FZ.f @@ -0,0 +1,733 @@ + SUBROUTINE TG01FZ( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22, + $ TOL, IWORK, DWORK, ZWORK, LZWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute for the descriptor system (A-lambda E,B,C) +C the unitary transformation matrices Q and Z such that the +C transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is +C in a SVD-like coordinate form with +C +C ( A11 A12 ) ( Er 0 ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , +C ( A21 A22 ) ( 0 0 ) +C +C where Er is an upper triangular invertible matrix, and ' denotes +C the conjugate transpose. Optionally, the A22 matrix can be further +C reduced to the form +C +C ( Ar X ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix, and X either a full +C or a zero matrix. +C The left and/or right unitary transformations performed +C to reduce E and A22 can be optionally accumulated. +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C unitary matrix Q is returned; +C = 'U': Q must contain a unitary matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C unitary matrix Z is returned; +C = 'U': Z must contain a unitary matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C JOBA CHARACTER*1 +C = 'N': do not reduce A22; +C = 'R': reduce A22 to a SVD-like upper triangular form. +C = 'T': reduce A22 to an upper trapezoidal form. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of rows of matrices A, B, and E. L >= 0. +C +C N (input) INTEGER +C The number of columns of matrices A, E, and C. N >= 0. +C +C M (input) INTEGER +C The number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The number of rows of matrix C. P >= 0. +C +C A (input/output) COMPLEX*16 array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the state dynamics matrix A. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix +C is in the form +C +C ( A11 * * ) +C Q'*A*Z = ( * Ar X ) , +C ( * 0 0 ) +C +C where A11 is a RANKE-by-RANKE matrix and Ar is a +C RNKA22-by-RNKA22 invertible upper triangular matrix. +C If JOBA = 'R' then A has the above form with X = 0. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) COMPLEX*16 array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the descriptor matrix E. +C On exit, the leading L-by-N part of this array contains +C the transformed matrix Q'*E*Z. +C +C ( Er 0 ) +C Q'*E*Z = ( ) , +C ( 0 0 ) +C +C where Er is a RANKE-by-RANKE upper triangular invertible +C matrix. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) COMPLEX*16 array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the input/state matrix B. +C On exit, the leading L-by-M part of this array contains +C the transformed matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) COMPLEX*16 array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) COMPLEX*16 array, dimension (LDQ,L) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading L-by-L part of this +C array contains the unitary matrix Q, +C where Q' is the product of Householder +C transformations which are applied to A, +C E, and B on the left. +C If COMPQ = 'U': on entry, the leading L-by-L part of this +C array must contain a unitary matrix Q1; +C on exit, the leading L-by-L part of this +C array contains the unitary matrix Q1*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. +C +C Z (input/output) COMPLEX*16 array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the unitary matrix Z, +C which is the product of Householder +C transformations applied to A, E, and C +C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain a unitary matrix Z1; +C on exit, the leading N-by-N part of this +C array contains the unitary matrix Z1*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C RANKE (output) INTEGER +C The estimated rank of matrix E, and thus also the order +C of the invertible upper triangular submatrix Er. +C +C RNKA22 (output) INTEGER +C If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of +C matrix A22, and thus also the order of the invertible +C upper triangular submatrix Ar. +C If JOBA = 'N', then RNKA22 is not referenced. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in determining the rank of E +C and of A22. If the user sets TOL > 0, then the given +C value of TOL is used as a lower bound for the +C reciprocal condition numbers of leading submatrices +C of R or R22 in the QR decompositions E * P = Q * R of E +C or A22 * P22 = Q22 * R22 of A22. +C A submatrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = L*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (N) +C +C DWORK DOUBLE PRECISION array, dimension (2*N) +C +C ZWORK DOUBLE PRECISION array, dimension (LZWORK) +C On exit, if INFO = 0, ZWORK(1) returns the optimal value +C of LZWORK. +C +C LZWORK INTEGER +C The length of the array ZWORK. +C LZWORK >= MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ). +C For optimal performance, LZWORK should be larger. +C +C If LZWORK = -1, then a workspace query is assumed; +C the routine only calculates the optimal size of the +C ZWORK array, returns this value as the first entry of +C the ZWORK array, and no error message related to LZWORK +C is issued by XERBLA. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine computes a truncated QR factorization with column +C pivoting of E, in the form +C +C ( E11 E12 ) +C E * P = Q * ( ) +C ( 0 E22 ) +C +C and finds the largest RANKE-by-RANKE leading submatrix E11 whose +C estimated condition number is less than 1/TOL. RANKE defines thus +C the rank of matrix E. Further E22, being negligible, is set to +C zero, and a unitary matrix Y is determined such that +C +C ( E11 E12 ) = ( Er 0 ) * Y . +C +C The overal transformation matrix Z results as Z = P * Y' and the +C resulting transformed matrices Q'*A*Z and Q'*E*Z have the form +C +C ( Er 0 ) ( A11 A12 ) +C E <- Q'* E * Z = ( ) , A <- Q' * A * Z = ( ) , +C ( 0 0 ) ( A21 A22 ) +C +C where Er is an upper triangular invertible matrix. +C If JOBA = 'R' the same reduction is performed on A22 to obtain it +C in the form +C +C ( Ar 0 ) +C A22 = ( ) , +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix. +C If JOBA = 'T' then A22 is row compressed using the QR +C factorization with column pivoting to the form +C +C ( Ar X ) +C A22 = ( ) +C ( 0 0 ) +C +C with Ar an upper triangular invertible matrix. +C +C The transformations are also applied to the rest of system +C matrices +C +C B <- Q' * B, C <- C * Z. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( L*L*N ) floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Nov. 2008. +C +C REVISIONS +C +C - +C +C KEYWORDS +C +C Descriptor system, matrix algebra, matrix operations, unitary +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) + DOUBLE PRECISION DONE, DZERO + PARAMETER ( DONE = 1.0D+0, DZERO = 0.0D+0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBA + INTEGER INFO, L, LDA, LDB, LDC, LDE, LDQ, LDZ, LZWORK, + $ M, N, P, RANKE, RNKA22 + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ E( LDE, * ), Q( LDQ, * ), Z( LDZ, * ), + $ ZWORK( * ) + DOUBLE PRECISION DWORK( * ) +C .. Local Scalars .. + LOGICAL ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC + INTEGER I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22, + $ LH, LN, LWR, NA22, NB, WRKOPT + DOUBLE PRECISION SVLMAX, TOLDEF +C .. Local Arrays .. + DOUBLE PRECISION SVAL(3) +C .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL DLAMCH, ILAENV, LSAME, ZLANGE +C .. External Subroutines .. + EXTERNAL MB3OYZ, XERBLA, ZLASET, ZSWAP, ZTZRZF, ZUNMQR, + $ ZUNMRZ +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF + REDA = LSAME( JOBA, 'R' ) + REDTR = LSAME( JOBA, 'T' ) + WITHB = M.GT.0 + WITHC = P.GT.0 + LQUERY = ( LZWORK.EQ.-1 ) +C +C Test the input parameters. +C + LN = MIN( L, N ) + INFO = 0 + WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) ) + IF( ICOMPQ.LE.0 ) THEN + INFO = -1 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND. + $ .NOT.REDTR ) THEN + INFO = -3 + ELSE IF( L.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( P.LT.0 ) THEN + INFO = -7 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -9 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -11 + ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN + INFO = -13 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -15 + ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN + INFO = -17 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -19 + ELSE IF( TOL.GE.DONE ) THEN + INFO = -22 + ELSE + IF( LQUERY ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', L, N, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + N*NB ) + IF( WITHB ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'LC', L, M, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + M*NB ) + END IF + IF( ILQ ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMQR', 'RN', L, L, LN, -1 ) ) + WRKOPT = MAX( WRKOPT, LN + L*NB ) + END IF + NB = ILAENV( 1, 'ZGERQF', ' ', L, N, -1, -1 ) + WRKOPT = MAX( WRKOPT, LN + N*NB ) + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', L, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, L )*NB ) + IF( WITHC ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', P, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, P )*NB ) + END IF + IF( ILZ ) THEN + NB = MIN( 64, ILAENV( 1, 'ZUNMRQ', 'RC', N, N, N, -1 ) ) + WRKOPT = MAX( WRKOPT, N + MAX( 1, N )*NB ) + END IF + ELSE IF( LZWORK.LT.WRKOPT ) THEN + INFO = -26 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01FZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + ZWORK(1) = WRKOPT + RETURN + END IF +C +C Initialize Q and Z if necessary. +C + IF( ICOMPQ.EQ.3 ) + $ CALL ZLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL ZLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Quick return if possible. +C + IF( L.EQ.0 .OR. N.EQ.0 ) THEN + ZWORK(1) = ONE + RANKE = 0 + IF( REDA .OR. REDTR ) RNKA22 = 0 + RETURN + END IF +C + TOLDEF = TOL + IF( TOLDEF.LE.DZERO ) THEN +C +C Use the default tolerance for rank determination. +C + TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' ) + END IF +C +C Set the estimate of maximum singular value of E to +C max(||E||,||A||) to detect negligible A or E matrices. +C + SVLMAX = MAX( ZLANGE( 'F', L, N, E, LDE, DWORK ), + $ ZLANGE( 'F', L, N, A, LDA, DWORK ) ) +C +C Compute the rank-revealing QR decomposition of E, +C +C ( E11 E12 ) +C E * P = Qr * ( ) , +C ( 0 E22 ) +C +C and determine the rank of E using incremental condition +C estimation. +C Complex Workspace: MIN(L,N) + 3*N - 1. +C Real Workspace: 2*N. +C + LWR = LZWORK - LN + KW = LN + 1 +C + CALL MB3OYZ( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK, + $ ZWORK, DWORK, ZWORK(KW), INFO ) +C +C Apply transformation on the rest of matrices. +C + IF( RANKE.GT.0 ) THEN +C +C A <-- Qr' * A. +C Complex Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL ZUNMQR( 'Left', 'ConjTranspose', L, N, RANKE, E, LDE, + $ ZWORK, A, LDA, ZWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) +C +C B <-- Qr' * B. +C Complex Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF( WITHB ) THEN + CALL ZUNMQR( 'Left', 'ConjTranspose', L, M, RANKE, E, LDE, + $ ZWORK, B, LDB, ZWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) + END IF +C +C Q <-- Q * Qr. +C Complex Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) THEN + CALL ZUNMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE, + $ ZWORK, Q, LDQ, ZWORK(KW), LWR, INFO ) + WRKOPT = MAX( WRKOPT, LN + INT( ZWORK(KW) ) ) + END IF +C +C Set lower triangle of E to zero. +C + IF( L.GE.2 ) + $ CALL ZLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE ) +C +C Compute A*P, C*P and Z*P by forward permuting the columns of +C A, C and Z based on information in IWORK. +C + DO 10 J = 1, N + IWORK(J) = -IWORK(J) + 10 CONTINUE + DO 30 I = 1, N + IF( IWORK(I).LT.0 ) THEN + J = I + IWORK(J) = -IWORK(J) + 20 CONTINUE + K = IWORK(J) + IF( IWORK(K).LT.0 ) THEN + CALL ZSWAP( L, A(1,J), 1, A(1,K), 1 ) + IF( WITHC ) + $ CALL ZSWAP( P, C(1,J), 1, C(1,K), 1 ) + IF( ILZ ) + $ CALL ZSWAP( N, Z(1,J), 1, Z(1,K), 1 ) + IWORK(K) = -IWORK(K) + J = K + GO TO 20 + END IF + END IF + 30 CONTINUE +C +C Determine a unitary matrix Y such that +C +C ( E11 E12 ) = ( Er 0 ) * Y . +C +C Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'. +C + IF( RANKE.LT.N ) THEN +C +C Complex Workspace: need 2*N; +C prefer N + N*NB. +C + KW = RANKE + 1 + CALL ZTZRZF( RANKE, N, E, LDE, ZWORK, ZWORK(KW), + $ LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) +C +C Complex Workspace: need N + MAX(L,P,N); +C prefer N + MAX(L,P,N)*NB. +C + LH = N - RANKE + CALL ZUNMRZ( 'Right', 'Conjugate transpose', L, N, RANKE, + $ LH, E, LDE, ZWORK, A, LDA, ZWORK(KW), + $ LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + IF( WITHC ) THEN + CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, RANKE, + $ LH, E, LDE, ZWORK, C, LDC, ZWORK(KW), + $ LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + END IF + IF( ILZ ) THEN + CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, RANKE, + $ LH, E, LDE, ZWORK, Z, LDZ, ZWORK(KW), + $ LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + END IF +C +C Set E12 and E22 to zero. +C + CALL ZLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE ) + END IF + ELSE + CALL ZLASET( 'Full', L, N, ZERO, ZERO, E, LDE ) + END IF +C +C Reduce A22 if necessary. +C + IF( REDA .OR. REDTR ) THEN + LA22 = L - RANKE + NA22 = N - RANKE + IF( MIN( LA22, NA22 ).EQ.0 ) THEN + RNKA22 = 0 + ELSE +C +C Compute the rank-revealing QR decomposition of A22, +C +C ( R11 R12 ) +C A22 * P2 = Q2 * ( ) , +C ( 0 R22 ) +C +C and determine the rank of A22 using incremental +C condition estimation. +C Complex Workspace: MIN(L,N) + 3*N - 1. +C Real Workspace: 2*N. +C + IR1 = RANKE + 1 + CALL MB3OYZ( LA22, NA22, A(IR1,IR1), LDA, TOLDEF, + $ SVLMAX, RNKA22, SVAL, IWORK, ZWORK, + $ DWORK, ZWORK(KW), INFO ) +C +C Apply transformation on the rest of matrices. +C + IF( RNKA22.GT.0 ) THEN +C +C A <-- diag(I, Q2') * A +C Complex Workspace: need MIN(L,N) + N; +C prefer MIN(L,N) + N*NB. +C + CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, RANKE, + $ RNKA22, A(IR1,IR1), LDA, ZWORK, A(IR1,1), + $ LDA, ZWORK(KW), LWR, INFO ) +C +C B <-- diag(I, Q2') * B +C Complex Workspace: need MIN(L,N) + M; +C prefer MIN(L,N) + M*NB. +C + IF ( WITHB ) + $ CALL ZUNMQR( 'Left', 'ConjTranspose', LA22, M, RNKA22, + $ A(IR1,IR1), LDA, ZWORK, B(IR1,1), LDB, + $ ZWORK(KW), LWR, INFO ) +C +C Q <-- Q * diag(I, Q2) +C Complex Workspace: need MIN(L,N) + L; +C prefer MIN(L,N) + L*NB. +C + IF( ILQ ) + $ CALL ZUNMQR( 'Right', 'No transpose', L, LA22, RNKA22, + $ A(IR1,IR1), LDA, ZWORK, Q(1,IR1), LDQ, + $ ZWORK(KW), LWR, INFO ) +C +C Set lower triangle of A22 to zero. +C + IF( LA22.GE.2 ) + $ CALL ZLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO, + $ A(IR1+1,IR1), LDA ) +C +C Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2) +C by forward permuting the columns of A, C and Z based +C on information in IWORK. +C + DO 40 J = 1, NA22 + IWORK(J) = -IWORK(J) + 40 CONTINUE + DO 60 I = 1, NA22 + IF( IWORK(I).LT.0 ) THEN + J = I + IWORK(J) = -IWORK(J) + 50 CONTINUE + K = IWORK(J) + IF( IWORK(K).LT.0 ) THEN + CALL ZSWAP( RANKE, A(1,RANKE+J), 1, + $ A(1,RANKE+K), 1 ) + IF( WITHC ) + $ CALL ZSWAP( P, C(1,RANKE+J), 1, + $ C(1,RANKE+K), 1 ) + IF( ILZ ) + $ CALL ZSWAP( N, Z(1,RANKE+J), 1, + $ Z(1,RANKE+K), 1 ) + IWORK(K) = -IWORK(K) + J = K + GO TO 50 + END IF + END IF + 60 CONTINUE +C + IF( REDA .AND. RNKA22.LT.NA22 ) THEN +C +C Determine a unitary matrix Y2 such that +C +C ( R11 R12 ) = ( Ar 0 ) * Y2 . +C +C Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'), +C Z <-- Z*diag(I, Y2'). +C +C Complex Workspace: need 2*N; +C prefer N + N*NB. +C + KW = RANKE + 1 + CALL ZTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, ZWORK, + $ ZWORK(KW), LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) +C +C Complex Workspace: need N + MAX(P,N); +C prefer N + MAX(P,N)*NB. +C + LH = NA22 - RNKA22 + IF( WITHC ) THEN + CALL ZUNMRZ( 'Right', 'Conjugate transpose', P, N, + $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, C, + $ LDC, ZWORK(KW), LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + END IF + IF( ILZ ) THEN + CALL ZUNMRZ( 'Right', 'Conjugate transpose', N, N, + $ RNKA22, LH, A(IR1,IR1), LDA, ZWORK, Z, + $ LDZ, ZWORK(KW), LZWORK-KW+1, INFO ) + WRKOPT = MAX( WRKOPT, INT( ZWORK(KW) ) + KW - 1 ) + END IF + IRE1 = RANKE + RNKA22 + 1 +C +C Set R12 and R22 to zero. +C + CALL ZLASET( 'Full', LA22, LH, ZERO, ZERO, + $ A(IR1,IRE1), LDA ) + END IF + ELSE + CALL ZLASET( 'Full', LA22, NA22, ZERO, ZERO, + $ A(IR1,IR1), LDA) + END IF + END IF + END IF +C + ZWORK(1) = WRKOPT +C + RETURN +C *** Last line of TG01FZ *** + END diff --git a/mex/sources/libslicot/TG01HD.f b/mex/sources/libslicot/TG01HD.f new file mode 100644 index 000000000..318f1f353 --- /dev/null +++ b/mex/sources/libslicot/TG01HD.f @@ -0,0 +1,545 @@ + SUBROUTINE TG01HD( JOBCON, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, NIUCON, + $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute orthogonal transformation matrices Q and Z which +C reduce the N-th order descriptor system (A-lambda*E,B,C) +C to the form +C +C ( Ac * ) ( Ec * ) ( Bc ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , +C ( 0 Anc ) ( 0 Enc ) ( 0 ) +C +C C*Z = ( Cc Cnc ) , +C +C where the NCONT-th order descriptor system (Ac-lambda*Ec,Bc,Cc) +C is a finite and/or infinite controllable. The pencil +C Anc - lambda*Enc is regular of order N-NCONT and contains the +C uncontrollable finite and/or infinite eigenvalues of the pencil +C A-lambda*E. +C +C For JOBCON = 'C' or 'I', the pencil ( Bc Ec-lambda*Ac ) has full +C row rank NCONT for all finite lambda and is in a staircase form +C with +C _ _ _ _ +C ( E1,0 E1,1 ... E1,k-1 E1,k ) +C ( _ _ _ ) +C ( Bc Ec ) = ( 0 E2,1 ... E2,k-1 E2,k ) , (1) +C ( ... _ _ ) +C ( 0 0 ... Ek,k-1 Ek,k ) +C +C _ _ _ +C ( A1,1 ... A1,k-1 A1,k ) +C ( _ _ ) +C Ac = ( 0 ... A2,k-1 A2,k ) , (2) +C ( ... _ ) +C ( 0 ... 0 Ak,k ) +C _ +C where Ei,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix +C _ +C (with rtau(0) = M) and Ai,i is an rtau(i)-by-rtau(i) +C upper triangular matrix. +C +C For JOBCON = 'F', the pencil ( Bc Ac-lambda*Ec ) has full +C row rank NCONT for all finite lambda and is in a staircase form +C with +C _ _ _ _ +C ( A1,0 A1,1 ... A1,k-1 A1,k ) +C ( _ _ _ ) +C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (3) +C ( ... _ _ ) +C ( 0 0 ... Ak,k-1 Ak,k ) +C +C _ _ _ +C ( E1,1 ... E1,k-1 E1,k ) +C ( _ _ ) +C Ec = ( 0 ... E2,k-1 E2,k ) , (4) +C ( ... _ ) +C ( 0 ... 0 Ek,k ) +C _ +C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank matrix +C _ +C (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) +C upper triangular matrix. +C +C For JOBCON = 'C', the (N-NCONT)-by-(N-NCONT) regular pencil +C Anc - lambda*Enc has the form +C +C ( Ainc - lambda*Einc * ) +C Anc - lambda*Enc = ( ) , +C ( 0 Afnc - lambda*Efnc ) +C +C where: +C 1) the NIUCON-by-NIUCON regular pencil Ainc - lambda*Einc, +C with Ainc upper triangular and nonsingular, contains the +C uncontrollable infinite eigenvalues of A - lambda*E; +C 2) the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) regular pencil +C Afnc - lambda*Efnc, with Efnc upper triangular and +C nonsingular, contains the uncontrollable finite +C eigenvalues of A - lambda*E. +C +C Note: The significance of the two diagonal blocks can be +C interchanged by calling the routine with the +C arguments A and E interchanged. In this case, +C Ainc - lambda*Einc contains the uncontrollable zero +C eigenvalues of A - lambda*E, while Afnc - lambda*Efnc +C contains the uncontrollable nonzero finite and infinite +C eigenvalues of A - lambda*E. +C +C For JOBCON = 'F', the pencil Anc - lambda*Enc has the form +C +C Anc - lambda*Enc = Afnc - lambda*Efnc , +C +C where the regular pencil Afnc - lambda*Efnc, with Efnc +C upper triangular and nonsingular, contains the uncontrollable +C finite eigenvalues of A - lambda*E. +C +C For JOBCON = 'I', the pencil Anc - lambda*Enc has the form +C +C Anc - lambda*Enc = Ainc - lambda*Einc , +C +C where the regular pencil Ainc - lambda*Einc, with Ainc +C upper triangular and nonsingular, contains the uncontrollable +C nonzero finite and infinite eigenvalues of A - lambda*E. +C +C The left and/or right orthogonal transformations Q and Z +C performed to reduce the system matrices can be optionally +C accumulated. +C +C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has +C the same transfer-function matrix as the original system +C (A-lambda*E,B,C). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBCON CHARACTER*1 +C = 'C': separate both finite and infinite uncontrollable +C eigenvalues; +C = 'F': separate only finite uncontrollable eigenvalues: +C = 'I': separate only nonzero finite and infinite +C uncontrollable eigenvalues. +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the descriptor state vector; also the +C order of square matrices A and E, the number of rows of +C matrix B, and the number of columns of matrix C. N >= 0. +C +C M (input) INTEGER +C The dimension of descriptor system input vector; also the +C number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The dimension of descriptor system output vector; also the +C number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed state matrix Q'*A*Z, +C +C ( Ac * ) +C Q'*A*Z = ( ) , +C ( 0 Anc ) +C +C where Ac is NCONT-by-NCONT and Anc is +C (N-NCONT)-by-(N-NCONT). +C If JOBCON = 'F', the matrix ( Bc Ac ) is in the +C controllability staircase form (3). +C If JOBCON = 'C' or 'I', the submatrix Ac is upper +C triangular. +C If JOBCON = 'C', the Anc matrix has the form +C +C ( Ainc * ) +C Anc = ( ) , +C ( 0 Afnc ) +C +C where the NIUCON-by-NIUCON matrix Ainc is nonsingular and +C upper triangular. +C If JOBCON = 'I', Anc is nonsingular and upper triangular. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N descriptor matrix E. +C On exit, the leading N-by-N part of this array contains +C the transformed descriptor matrix Q'*E*Z, +C +C ( Ec * ) +C Q'*E*Z = ( ) , +C ( 0 Enc ) +C +C where Ec is NCONT-by-NCONT and Enc is +C (N-NCONT)-by-(N-NCONT). +C If JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the +C controllability staircase form (1). +C If JOBCON = 'F', the submatrix Ec is upper triangular. +C If JOBCON = 'C', the Enc matrix has the form +C +C ( Einc * ) +C Enc = ( ) , +C ( 0 Efnc ) +C +C where the NIUCON-by-NIUCON matrix Einc is nilpotent +C and the (N-NCONT-NIUCON)-by-(N-NCONT-NIUCON) matrix Efnc +C is nonsingular and upper triangular. +C If JOBCON = 'F', Enc is nonsingular and upper triangular. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the N-by-M input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix +C +C ( Bc ) +C Q'*B = ( ) , +C ( 0 ) +C +C where Bc is NCONT-by-M. +C For JOBCON = 'C' or 'I', the matrix ( Bc Ec ) is in the +C controllability staircase form (1). +C For JOBCON = 'F', the matrix ( Bc Ac ) is in the +C controllability staircase form (3). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of transformations +C which are applied to A, E, and B on +C the left. +C If COMPQ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Qc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Qc*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of transformations +C applied to A, E, and C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Zc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Zc*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C NCONT (output) INTEGER +C The order of the reduced matrices Ac and Ec, and the +C number of rows of reduced matrix Bc; also the order of +C the controllable part of the pair (A-lambda*E,B). +C +C NIUCON (output) INTEGER +C For JOBCON = 'C', the order of the reduced matrices +C Ainc and Einc; also the number of uncontrollable +C infinite eigenvalues of the pencil A - lambda*E. +C For JOBCON = 'F' or 'I', NIUCON has no significance +C and is set to zero. +C +C NRBLCK (output) INTEGER +C For JOBCON = 'C' or 'I', the number k, of full row rank +C _ +C blocks Ei,i in the staircase form of the pencil +C (Bc Ec-lambda*Ac) (see (1) and (2)). +C For JOBCON = 'F', the number k, of full row rank blocks +C _ +C Ai,i in the staircase form of the pencil (Bc Ac-lambda*Ec) +C (see (3) and (4)). +C +C RTAU (output) INTEGER array, dimension (N) +C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of +C _ _ +C the full row rank block Ei,i-1 or Ai,i-1 in the staircase +C form (1) or (3) for JOBCON = 'C' or 'I', or +C for JOBCON = 'F', respectively. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determinations when +C transforming (A-lambda*E, B). If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C reciprocal condition numbers in rank determinations; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension MAX(N,2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithms of [1]. +C +C REFERENCES +C +C [1] A. Varga +C Computation of Irreducible Generalized State-Space +C Realizations. +C Kybernetika, vol. 26, pp. 89-106, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( N**3 ) floating point operations. +C +C FURTHER COMMENTS +C +C If the system matrices A, E and B are badly scaled, it is +C generally recommendable to scale them with the SLICOT routine +C TG01AD, before calling TG01HD. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSCF. +C +C REVISIONS +C +C July 1999, V. Sima, Research Institute for Informatics, Bucharest. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBCON + INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, + $ M, N, NCONT, NIUCON, NRBLCK, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK( * ), RTAU( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + CHARACTER JOBQ, JOBZ + LOGICAL FINCON, ILQ, ILZ, INFCON + INTEGER ICOMPQ, ICOMPZ, LBA, NR +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL TG01HX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Decode JOBCON. +C + IF( LSAME( JOBCON, 'C' ) ) THEN + FINCON = .TRUE. + INFCON = .TRUE. + ELSE IF( LSAME( JOBCON, 'F' ) ) THEN + FINCON = .TRUE. + INFCON = .FALSE. + ELSE IF( LSAME( JOBCON, 'I' ) ) THEN + FINCON = .FALSE. + INFCON = .TRUE. + ELSE + FINCON = .FALSE. + INFCON = .FALSE. + END IF +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +C +C Test the input scalar parameters. +C + INFO = 0 + IF( .NOT.FINCON .AND. .NOT.INFCON ) THEN + INFO = -1 + ELSE IF( ICOMPQ.LE.0 ) THEN + INFO = -2 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -14 + ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -16 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -18 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -23 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01HD', -INFO ) + RETURN + END IF +C + JOBQ = COMPQ + JOBZ = COMPZ +C + IF( FINCON ) THEN +C +C Perform finite controllability form reduction. +C + CALL TG01HX( JOBQ, JOBZ, N, N, M, P, N, MAX( 0, N-1 ), A, LDA, + $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, + $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) + IF( NRBLCK.GT.1 ) THEN + LBA = RTAU(1) + RTAU(2) - 1 + ELSE IF( NRBLCK.EQ.1 ) THEN + LBA = RTAU(1) - 1 + ELSE + LBA = 0 + END IF + IF( ILQ ) JOBQ = 'U' + IF( ILZ ) JOBZ = 'U' + ELSE + NR = N + LBA = MAX( 0, N-1 ) + END IF +C + IF( INFCON ) THEN +C +C Perform infinite controllability form reduction. +C + CALL TG01HX( JOBQ, JOBZ, N, N, M, P, NR, LBA, E, LDE, + $ A, LDA, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NCONT, + $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) + IF( FINCON ) THEN + NIUCON = NR - NCONT + ELSE + NIUCON = 0 + END IF + ELSE + NCONT = NR + NIUCON = 0 + END IF +C + RETURN +C +C *** Last line of TG01HD *** + END diff --git a/mex/sources/libslicot/TG01HX.f b/mex/sources/libslicot/TG01HX.f new file mode 100644 index 000000000..c0717f81a --- /dev/null +++ b/mex/sources/libslicot/TG01HX.f @@ -0,0 +1,694 @@ + SUBROUTINE TG01HX( COMPQ, COMPZ, L, N, M, P, N1, LBE, A, LDA, + $ E, LDE, B, LDB, C, LDC, Q, LDQ, Z, LDZ, NR, + $ NRBLCK, RTAU, TOL, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C Given the descriptor system (A-lambda*E,B,C) with the system +C matrices A, E and B of the form +C +C ( A1 X1 ) ( E1 Y1 ) ( B1 ) +C A = ( ) , E = ( ) , B = ( ) , +C ( 0 X2 ) ( 0 Y2 ) ( 0 ) +C +C where +C - B is an L-by-M matrix, with B1 an N1-by-M submatrix +C - A is an L-by-N matrix, with A1 an N1-by-N1 submatrix +C - E is an L-by-N matrix, with E1 an N1-by-N1 submatrix +C with LBE nonzero sub-diagonals, +C this routine reduces the pair (A1-lambda*E1,B1) to the form +C +C Qc'*[A1-lambda*E1 B1]*diag(Zc,I) = +C +C ( Bc Ac-lambda*Ec * ) +C ( ) , +C ( 0 0 Anc-lambda*Enc ) +C +C where: +C 1) the pencil ( Bc Ac-lambda*Ec ) has full row rank NR for +C all finite lambda and is in a staircase form with +C _ _ _ _ +C ( A1,0 A1,1 ... A1,k-1 A1,k ) +C ( _ _ _ ) +C ( Bc Ac ) = ( 0 A2,1 ... A2,k-1 A2,k ) , (1) +C ( ... _ _ ) +C ( 0 0 ... Ak,k-1 Ak,k ) +C +C _ _ _ +C ( E1,1 ... E1,k-1 E1,k ) +C ( _ _ ) +C Ec = ( 0 ... E2,k-1 E2,k ) , (2) +C ( ... _ ) +C ( 0 ... 0 Ek,k ) +C _ +C where Ai,i-1 is an rtau(i)-by-rtau(i-1) full row rank +C _ +C matrix (with rtau(0) = M) and Ei,i is an rtau(i)-by-rtau(i) +C upper triangular matrix. +C +C 2) the pencil Anc-lambda*Enc is regular of order N1-NR with Enc +C upper triangular; this pencil contains the uncontrollable +C finite eigenvalues of the pencil (A1-lambda*E1). +C +C The transformations are applied to the whole matrices A, E, B +C and C. The left and/or right orthogonal transformations Qc and Zc +C performed to reduce the pencil S(lambda) can be optionally +C accumulated in the matrices Q and Z, respectivelly. +C +C The reduced order descriptor system (Ac-lambda*Ec,Bc,Cc) has no +C uncontrollable finite eigenvalues and has the same +C transfer-function matrix as the original system (A-lambda*E,B,C). +C +C ARGUMENTS +C +C Mode Parameters +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C L (input) INTEGER +C The number of descriptor state equations; also the number +C of rows of matrices A, E and B. L >= 0. +C +C N (input) INTEGER +C The dimension of the descriptor state vector; also the +C number of columns of matrices A, E and C. N >= 0. +C +C M (input) INTEGER +C The dimension of descriptor system input vector; also the +C number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The dimension of descriptor system output; also the +C number of rows of matrix C. P >= 0. +C +C N1 (input) INTEGER +C The order of subsystem (A1-lambda*E1,B1,C1) to be reduced. +C MIN(L,N) >= N1 >= 0. +C +C LBE (input) INTEGER +C The number of nonzero sub-diagonals of submatrix E1. +C MAX(0,N1-1) >= LBE >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading L-by-N part of this array must +C contain the L-by-N state matrix A in the partitioned +C form +C ( A1 X1 ) +C A = ( ) , +C ( 0 X2 ) +C +C where A1 is N1-by-N1. +C On exit, the leading L-by-N part of this array contains +C the transformed state matrix, +C +C ( Ac * * ) +C Qc'*A*Zc = ( 0 Anc * ) , +C ( 0 0 * ) +C +C where Ac is NR-by-NR and Anc is (N1-NR)-by-(N1-NR). +C The matrix ( Bc Ac ) is in the controlability +C staircase form (1). +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,L). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading L-by-N part of this array must +C contain the L-by-N descriptor matrix E in the partitioned +C form +C ( E1 Y1 ) +C E = ( ) , +C ( 0 Y2 ) +C +C where E1 is N1-by-N1 matrix with LBE nonzero +C sub-diagonals. +C On exit, the leading L-by-N part of this array contains +C the transformed descriptor matrix +C +C ( Ec * * ) +C Qc'*E*Zc = ( 0 Enc * ) , +C ( 0 0 * ) +C +C where Ec is NR-by-NR and Enc is (N1-NR)-by-(N1-NR). +C Both Ec and Enc are upper triangular and Enc is +C nonsingular. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,L). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading L-by-M part of this array must +C contain the L-by-M input matrix B in the partitioned +C form +C ( B1 ) +C B = ( ) , +C ( 0 ) +C +C where B1 is N1-by-M. +C On exit, the leading L-by-M part of this array contains +C the transformed input matrix +C +C ( Bc ) +C Qc'*B = ( ) , +C ( 0 ) +C +C where Bc is NR-by-M. +C The matrix ( Bc Ac ) is in the controlability +C staircase form (1). +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,L). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix C*Zc. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,L) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of transformations +C which are applied to A, E, and B on +C the left. +C If COMPQ = 'U': on entry, the leading L-by-L part of this +C array must contain an orthogonal matrix +C Qc; +C on exit, the leading L-by-L part of this +C array contains the orthogonal matrix +C Qc*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of transformations +C applied to A, E, and C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Zc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Zc*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C NR (output) INTEGER +C The order of the reduced matrices Ac and Ec, and the +C number of rows of the reduced matrix Bc; also the order of +C the controllable part of the pair (B, A-lambda*E). +C +C NRBLCK (output) INTEGER _ +C The number k, of full row rank blocks Ai,i in the +C staircase form of the pencil (Bc Ac-lambda*Ec) (see (1) +C and (2)). +C +C RTAU (output) INTEGER array, dimension (N1) +C RTAU(i), for i = 1, ..., NRBLCK, is the row dimension of +C _ +C the full row rank block Ai,i-1 in the staircase form (1). +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determinations when +C transforming (A-lambda*E, B). If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C reciprocal condition numbers in rank determinations; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = L*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (M) +C +C DWORK DOUBLE PRECISION array, dimension MAX(N,L,2*M) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithm of [1]. +C +C REFERENCES +C +C [1] A. Varga +C Computation of Irreducible Generalized State-Space +C Realizations. +C Kybernetika, vol. 26, pp. 89-106, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( N*N1**2 ) floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDS05. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, July 1999, +C May 2003, Nov. 2003. +C A. Varga, German Aerospace Center, Oberpfaffenhofen, Nov. 2003. +C +C KEYWORDS +C +C Controllability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + INTEGER IMAX, IMIN + PARAMETER ( IMAX = 1, IMIN = 2 ) + DOUBLE PRECISION ONE, P05, ZERO + PARAMETER ( ONE = 1.0D0, P05 = 0.05D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ + INTEGER INFO, L, LBE, LDA, LDB, LDC, LDE, LDQ, LDZ, M, + $ N, N1, NR, NRBLCK, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER IWORK( * ), RTAU( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + LOGICAL ILQ, ILZ, WITHC + INTEGER I, IC, ICOL, ICOMPQ, ICOMPZ, IROW, ISMAX, + $ ISMIN, J, K, MN, NF, NR1, RANK, TAUIM1 + DOUBLE PRECISION CO, C1, C2, RCOND, SMAX, SMAXPR, SMIN, SMINPR, + $ SVLMAX, S1, S2, SI, T, TT +C .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLANGE, DLAPY2, DNRM2, IDAMAX, LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, DLARF, DLARFG, DLARTG, DLASET, DROT, + $ DSWAP, XERBLA +C .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +C +C .. Executable Statements .. +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +C +C Test the input scalar parameters. +C + INFO = 0 + IF( ICOMPQ.LE.0 ) THEN + INFO = -1 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -2 + ELSE IF( L.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( N1.LT.0 .OR. N1.GT.MIN( L, N ) ) THEN + INFO = -7 + ELSE IF( LBE.LT.0 .OR. LBE.GT.MAX( 0, N1-1 ) ) THEN + INFO = -8 + ELSE IF( LDA.LT.MAX( 1, L ) ) THEN + INFO = -10 + ELSE IF( LDE.LT.MAX( 1, L ) ) THEN + INFO = -12 + ELSE IF( LDB.LT.MAX( 1, L ) ) THEN + INFO = -14 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -16 + ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN + INFO = -18 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -20 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -24 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01HX', -INFO ) + RETURN + END IF +C +C Initialize Q and Z if necessary. +C + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +C +C Initialize output variables. +C + NR = 0 + NRBLCK = 0 +C +C Quick return if possible. +C + IF( M.EQ.0 .OR. N1.EQ.0 ) THEN + RETURN + END IF +C + WITHC = P.GT.0 + SVLMAX = DLAPY2( DLANGE( 'F', L, M, B, LDB, DWORK ), + $ DLANGE( 'F', L, N, A, LDA, DWORK ) ) + RCOND = TOL + IF ( RCOND.LE.ZERO ) THEN +C +C Use the default tolerance in controllability determination. +C + RCOND = DBLE( L*N )*DLAMCH( 'EPSILON' ) + END IF +C + IF ( SVLMAX.LT.RCOND ) + $ SVLMAX = ONE +C +C Reduce E to upper triangular form if necessary. +C + IF( LBE.GT.0 ) THEN + DO 10 I = 1, N1-1 +C +C Generate elementary reflector H(i) to annihilate +C E(i+1:i+lbe,i). +C + K = MIN( LBE, N1-I ) + 1 + CALL DLARFG( K, E(I,I), E(I+1,I), 1, TT ) + T = E(I,I) + E(I,I) = ONE +C +C Apply H(i) to E(i:n1,i+1:n) from the left. +C + CALL DLARF( 'Left', K, N-I, E(I,I), 1, TT, + $ E(I,I+1), LDE, DWORK ) +C +C Apply H(i) to A(i:n1,1:n) from the left. +C + CALL DLARF( 'Left', K, N, E(I,I), 1, TT, + $ A(I,1), LDA, DWORK ) +C +C Apply H(i) to B(i:n1,1:m) from the left. +C + CALL DLARF( 'Left', K, M, E(I,I), 1, TT, + $ B(I,1), LDB, DWORK ) + IF( ILQ ) THEN +C +C Apply H(i) to Q(1:l,i:n1) from the right. +C + CALL DLARF( 'Right', L, K, E(I,I), 1, TT, + $ Q(1,I), LDQ, DWORK ) + END IF + E(I,I) = T + 10 CONTINUE + IF( N1.GT.1 ) + $ CALL DLASET( 'Lower', N1-1, N1-1, ZERO, ZERO, E(2,1), LDE ) + END IF +C + ISMIN = 1 + ISMAX = ISMIN + M + IC = -M + TAUIM1 = M + NF = N1 +C + 20 CONTINUE + NRBLCK = NRBLCK + 1 + RANK = 0 + IF( NF.GT.0 ) THEN +C +C IROW will point to the current pivot line in B, +C ICOL+1 will point to the first active columns of A. +C + ICOL = IC + TAUIM1 + IROW = NR + NR1 = NR + 1 + IF( NR.GT.0 ) + $ CALL DLACPY( 'Full', NF, TAUIM1, A(NR1,IC+1), LDA, + $ B(NR1,1), LDB ) +C +C Perform QR-decomposition with column pivoting on the current B +C while keeping E upper triangular. +C The current B is at first iteration B and for subsequent +C iterations the NF-by-TAUIM1 matrix delimited by rows +C NR + 1 to N1 and columns IC + 1 to IC + TAUIM1 of A. +C The rank of current B is computed in RANK. +C + IF( TAUIM1.GT.1 ) THEN +C +C Compute column norms. +C + DO 30 J = 1, TAUIM1 + DWORK(J) = DNRM2( NF, B(NR1,J), 1 ) + DWORK(M+J) = DWORK(J) + IWORK(J) = J + 30 CONTINUE + END IF +C + MN = MIN( NF, TAUIM1 ) +C + 40 CONTINUE + IF( RANK.LT.MN ) THEN + J = RANK + 1 + IROW = IROW + 1 +C +C Pivot if necessary. +C + IF( J.NE.TAUIM1 ) THEN + K = ( J - 1 ) + IDAMAX( TAUIM1-J+1, DWORK(J), 1 ) + IF( K.NE.J ) THEN + CALL DSWAP( NF, B(NR1,J), 1, B(NR1,K), 1 ) + I = IWORK(K) + IWORK(K) = IWORK(J) + IWORK(J) = I + DWORK(K) = DWORK(J) + DWORK(M+K) = DWORK(M+J) + END IF + END IF +C +C Zero elements below the current diagonal element of B. +C + DO 50 I = N1-1, IROW, -1 +C +C Rotate rows I and I+1 to zero B(I+1,J). +C + T = B(I,J) + CALL DLARTG( T, B(I+1,J), CO, SI, B(I,J) ) + B(I+1,J) = ZERO + CALL DROT( N-I+1, E(I,I), LDE, E(I+1,I), LDE, CO, SI ) + IF( J.LT.TAUIM1 ) + $ CALL DROT( TAUIM1-J, B(I,J+1), LDB, + $ B(I+1,J+1), LDB, CO, SI ) + CALL DROT( N-ICOL, A(I,ICOL+1), LDA, + $ A(I+1,ICOL+1), LDA, CO, SI ) + IF( ILQ ) CALL DROT( L, Q(1,I), 1, Q(1,I+1), 1, CO, SI ) +C +C Rotate columns I, I+1 to zero E(I+1,I). +C + T = E(I+1,I+1) + CALL DLARTG( T, E(I+1,I), CO, SI, E(I+1,I+1) ) + E(I+1,I) = ZERO + CALL DROT( I, E(1,I+1), 1, E(1,I), 1, CO, SI ) + CALL DROT( N1, A(1,I+1), 1, A(1,I), 1, CO, SI ) + IF( ILZ ) CALL DROT( N, Z(1,I+1), 1, Z(1,I), 1, CO, SI ) + IF( WITHC ) + $ CALL DROT( P, C(1,I+1), 1, C(1,I), 1, CO, SI ) + 50 CONTINUE +C + IF( RANK.EQ.0 ) THEN +C +C Initialize; exit if matrix is zero (RANK = 0). +C + SMAX = ABS( B(NR1,1) ) + IF ( SMAX.EQ.ZERO ) GO TO 80 + SMIN = SMAX + SMAXPR = SMAX + SMINPR = SMIN + C1 = ONE + C2 = ONE + ELSE +C +C One step of incremental condition estimation. +C + CALL DLAIC1( IMIN, RANK, DWORK(ISMIN), SMIN, + $ B(NR1,J), B(IROW,J), SMINPR, S1, C1 ) + CALL DLAIC1( IMAX, RANK, DWORK(ISMAX), SMAX, + $ B(NR1,J), B(IROW,J), SMAXPR, S2, C2 ) + END IF +C +C Check the rank; finish the loop if rank loss occurs. +C + IF( SVLMAX*RCOND.LE.SMAXPR ) THEN + IF( SVLMAX*RCOND.LE.SMINPR ) THEN + IF( SMAXPR*RCOND.LE.SMINPR ) THEN +C +C Finish the loop if last row. +C + IF( IROW.EQ.N1 ) THEN + RANK = RANK + 1 + GO TO 80 + END IF +C +C Update partial column norms. +C + DO 60 I = J + 1, TAUIM1 + IF( DWORK(I).NE.ZERO ) THEN + T = ONE - ( ABS( B(IROW,I) )/DWORK(I) )**2 + T = MAX( T, ZERO ) + TT = ONE + P05*T*( DWORK(I)/DWORK(M+I) )**2 + IF( TT.NE.ONE ) THEN + DWORK(I) = DWORK(I)*SQRT( T ) + ELSE + DWORK(I) = DNRM2( NF-J, B(IROW+1,I), 1 ) + DWORK(M+I) = DWORK(I) + END IF + END IF + 60 CONTINUE +C + DO 70 I = 1, RANK + DWORK(ISMIN+I-1) = S1*DWORK(ISMIN+I-1) + DWORK(ISMAX+I-1) = S2*DWORK(ISMAX+I-1) + 70 CONTINUE +C + DWORK(ISMIN+RANK) = C1 + DWORK(ISMAX+RANK) = C2 + SMIN = SMINPR + SMAX = SMAXPR + RANK = RANK + 1 + GO TO 40 + END IF + END IF + END IF + IF( NR.GT.0 ) THEN + CALL DLASET( 'Full', N1-IROW+1, TAUIM1-J+1, ZERO, ZERO, + $ B(IROW,J), LDB ) + END IF + GO TO 80 + END IF + END IF +C + 80 IF( RANK.GT.0 ) THEN + RTAU(NRBLCK) = RANK +C +C Back permute interchanged columns. +C + IF( TAUIM1.GT.1 ) THEN + DO 100 J = 1, TAUIM1 + IF( IWORK(J).GT.0 ) THEN + K = IWORK(J) + IWORK(J) = -K + 90 CONTINUE + IF( K.NE.J ) THEN + CALL DSWAP( RANK, B(NR1,J), 1, B(NR1,K), 1 ) + IWORK(K) = -IWORK(K) + K = -IWORK(K) + GO TO 90 + END IF + END IF + 100 CONTINUE + END IF + END IF + IF( NR.GT.0 ) + $ CALL DLACPY( 'Full', NF, TAUIM1, B(NR1,1), LDB, + $ A(NR1,IC+1), LDA ) + IF( RANK.GT.0 ) THEN + NR = NR + RANK + NF = NF - RANK + IC = IC + TAUIM1 + TAUIM1 = RANK + GO TO 20 + ELSE + NRBLCK = NRBLCK - 1 + END IF +C + IF( NRBLCK.GT.0 ) RANK = RTAU(1) + IF( RANK.LT.N1 ) + $ CALL DLASET( 'Full', N1-RANK, M, ZERO, ZERO, B(RANK+1,1), LDB ) +C + RETURN +C *** Last line of TG01HX *** + END diff --git a/mex/sources/libslicot/TG01ID.f b/mex/sources/libslicot/TG01ID.f new file mode 100644 index 000000000..dfd3888a3 --- /dev/null +++ b/mex/sources/libslicot/TG01ID.f @@ -0,0 +1,587 @@ + SUBROUTINE TG01ID( JOBOBS, COMPQ, COMPZ, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, Q, LDQ, Z, LDZ, NOBSV, NIUOBS, + $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To compute orthogonal transformation matrices Q and Z which +C reduce the N-th order descriptor system (A-lambda*E,B,C) +C to the form +C +C ( Ano * ) ( Eno * ) ( Bno ) +C Q'*A*Z = ( ) , Q'*E*Z = ( ) , Q'*B = ( ) , +C ( 0 Ao ) ( 0 Eo ) ( Bo ) +C +C C*Z = ( 0 Co ) , +C +C where the NOBSV-th order descriptor system (Ao-lambda*Eo,Bo,Co) +C is a finite and/or infinite observable. The pencil +C Ano - lambda*Eno is regular of order N-NOBSV and contains the +C unobservable finite and/or infinite eigenvalues of the pencil +C A-lambda*E. +C +C For JOBOBS = 'O' or 'I', the pencil ( Eo-lambda*Ao ) has full +C ( Co ) +C column rank NOBSV for all finite lambda and is in a staircase form +C with +C _ _ _ _ +C ( Ek,k Ek,k-1 ... Ek,2 Ek,1 ) +C ( _ _ _ _ ) +C ( Eo ) = ( Ek-1,k Ek-1,k-1 ... Ek-1,2 Ek-1,1 ) , (1) +C ( Co ) ( ... ... _ _ ) +C ( 0 0 ... E1,2 E1,1 ) +C ( _ ) +C ( 0 0 ... 0 E0,1 ) +C _ _ _ +C ( Ak,k ... Ak,2 Ak,1 ) +C ( ... _ _ ) +C Ao = ( 0 ... A2,2 A2,1 ) , (2) +C ( _ ) +C ( 0 ... 0 A1,1 ) +C _ +C where Ei-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix +C _ +C (with CTAU(0) = P) and Ai,i is a CTAU(i)-by-CTAU(i) +C upper triangular matrix. +C +C For JOBOBS = 'F', the pencil ( Ao-lambda*Eo ) has full +C ( Co ) +C column rank NOBSV for all finite lambda and is in a staircase form +C with +C _ _ _ _ +C ( Ak,k Ak,k-1 ... Ak,2 Ak,1 ) +C ( _ _ _ _ ) +C ( Ao ) = ( Ak-1,k Ak-1,k-1 ... Ak-1,2 Ak-1,1 ) , (3) +C ( Co ) ( ... ... _ _ ) +C ( 0 0 ... A1,2 A1,1 ) +C ( _ ) +C ( 0 0 ... 0 A0,1 ) +C _ _ _ +C ( Ek,k ... Ek,2 Ek,1 ) +C ( ... _ _ ) +C Eo = ( 0 ... E2,2 E2,1 ) , (4) +C ( _ ) +C ( 0 ... 0 E1,1 ) +C _ +C where Ai-1,i is a CTAU(i-1)-by-CTAU(i) full column rank matrix +C _ +C (with CTAU(0) = P) and Ei,i is a CTAU(i)-by-CTAU(i) +C upper triangular matrix. +C +C For JOBOBS = 'O', the (N-NOBSV)-by-(N-NOBSV) regular pencil +C Ano - lambda*Eno has the form +C +C ( Afno - lambda*Efno * ) +C Ano - lambda*Eno = ( ) , +C ( 0 Aino - lambda*Eino ) +C +C where: +C 1) the NIUOBS-by-NIUOBS regular pencil Aino - lambda*Eino, +C with Aino upper triangular and nonsingular, contains the +C unobservable infinite eigenvalues of A - lambda*E; +C 2) the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) regular pencil +C Afno - lambda*Efno, with Efno upper triangular and +C nonsingular, contains the unobservable finite +C eigenvalues of A - lambda*E. +C +C Note: The significance of the two diagonal blocks can be +C interchanged by calling the routine with the +C arguments A and E interchanged. In this case, +C Aino - lambda*Eino contains the unobservable zero +C eigenvalues of A - lambda*E, while Afno - lambda*Efno +C contains the unobservable nonzero finite and infinite +C eigenvalues of A - lambda*E. +C +C For JOBOBS = 'F', the pencil Ano - lambda*Eno has the form +C +C Ano - lambda*Eno = Afno - lambda*Efno , +C +C where the regular pencil Afno - lambda*Efno, with Efno +C upper triangular and nonsingular, contains the unobservable +C finite eigenvalues of A - lambda*E. +C +C For JOBOBS = 'I', the pencil Ano - lambda*Eno has the form +C +C Ano - lambda*Eno = Aino - lambda*Eino , +C +C where the regular pencil Aino - lambda*Eino, with Aino +C upper triangular and nonsingular, contains the unobservable +C nonzero finite and infinite eigenvalues of A - lambda*E. +C +C The left and/or right orthogonal transformations Q and Z +C performed to reduce the system matrices can be optionally +C accumulated. +C +C The reduced order descriptor system (Ao-lambda*Eo,Bo,Co) has +C the same transfer-function matrix as the original system +C (A-lambda*E,B,C). +C +C ARGUMENTS +C +C Mode Parameters +C +C JOBOBS CHARACTER*1 +C = 'O': separate both finite and infinite unobservable +C eigenvalues; +C = 'F': separate only finite unobservable eigenvalues; +C = 'I': separate only nonzero finite and infinite +C unobservable eigenvalues. +C +C COMPQ CHARACTER*1 +C = 'N': do not compute Q; +C = 'I': Q is initialized to the unit matrix, and the +C orthogonal matrix Q is returned; +C = 'U': Q must contain an orthogonal matrix Q1 on entry, +C and the product Q1*Q is returned. +C +C COMPZ CHARACTER*1 +C = 'N': do not compute Z; +C = 'I': Z is initialized to the unit matrix, and the +C orthogonal matrix Z is returned; +C = 'U': Z must contain an orthogonal matrix Z1 on entry, +C and the product Z1*Z is returned. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the descriptor state vector; also the +C order of square matrices A and E, the number of rows of +C matrix B, and the number of columns of matrix C. N >= 0. +C +C M (input) INTEGER +C The dimension of descriptor system input vector; also the +C number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The dimension of descriptor system output vector; also the +C number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N state matrix A. +C On exit, the leading N-by-N part of this array contains +C the transformed state matrix Q'*A*Z, +C +C ( Ano * ) +C Q'*A*Z = ( ) , +C ( 0 Ao ) +C +C where Ao is NOBSV-by-NOBSV and Ano is +C (N-NOBSV)-by-(N-NOBSV). +C If JOBOBS = 'F', the matrix ( Ao ) is in the observability +C ( Co ) +C staircase form (3). +C If JOBOBS = 'O' or 'I', the submatrix Ao is upper +C triangular. +C If JOBOBS = 'O', the submatrix Ano has the form +C +C ( Afno * ) +C Ano = ( ) , +C ( 0 Aino ) +C +C where the NIUOBS-by-NIUOBS matrix Aino is nonsingular and +C upper triangular. +C If JOBOBS = 'I', Ano is nonsingular and upper triangular. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the N-by-N descriptor matrix E. +C On exit, the leading N-by-N part of this array contains +C the transformed state matrix Q'*E*Z, +C +C ( Eno * ) +C Q'*E*Z = ( ) , +C ( 0 Eo ) +C +C where Eo is NOBSV-by-NOBSV and Eno is +C (N-NOBSV)-by-(N-NOBSV). +C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the +C ( Co ) +C observability staircase form (1). +C If JOBOBS = 'F', the submatrix Eo is upper triangular. +C If JOBOBS = 'O', the Eno matrix has the form +C +C ( Efno * ) +C Eno = ( ) , +C ( 0 Eino ) +C +C where the NIUOBS-by-NIUOBS matrix Eino is nilpotent +C and the (N-NOBSV-NIUOBS)-by-(N-NOBSV-NIUOBS) matrix Efno +C is nonsingular and upper triangular. +C If JOBOBS = 'F', Eno is nonsingular and upper triangular. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension +C (LDB,MAX(M,P)) +C On entry, the leading N-by-M part of this array must +C contain the N-by-M input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix Q'*B. +C +C LDB INTEGER +C The leading dimension of array B. +C LDB >= MAX(1,N) if M > 0 or LDB >= 1 if M = 0. +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the state/output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed matrix +C +C C*Z = ( 0 Co ) , +C +C where Co is P-by-NOBSV. +C If JOBOBS = 'O' or 'I', the matrix ( Eo ) is in the +C ( Co ) +C observability staircase form (1). +C If JOBOBS = 'F', the matrix ( Ao ) is in the observability +C ( Co ) +C staircase form (3). +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,M,P). +C +C Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N) +C If COMPQ = 'N': Q is not referenced. +C If COMPQ = 'I': on entry, Q need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Q, +C where Q' is the product of transformations +C which are applied to A, E, and B on +C the left. +C If COMPQ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Qc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Qc*Q. +C +C LDQ INTEGER +C The leading dimension of array Q. +C LDQ >= 1, if COMPQ = 'N'; +C LDQ >= MAX(1,N), if COMPQ = 'U' or 'I'. +C +C Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) +C If COMPZ = 'N': Z is not referenced. +C If COMPZ = 'I': on entry, Z need not be set; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix Z, +C which is the product of transformations +C applied to A, E, and C on the right. +C If COMPZ = 'U': on entry, the leading N-by-N part of this +C array must contain an orthogonal matrix +C Zc; +C on exit, the leading N-by-N part of this +C array contains the orthogonal matrix +C Zc*Z. +C +C LDZ INTEGER +C The leading dimension of array Z. +C LDZ >= 1, if COMPZ = 'N'; +C LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'. +C +C NOBSV (output) INTEGER +C The order of the reduced matrices Ao and Eo, and the +C number of columns of reduced matrix Co; also the order of +C observable part of the pair (C, A-lambda*E). +C +C NIUOBS (output) INTEGER +C For JOBOBS = 'O', the order of the reduced matrices +C Aino and Eino; also the number of unobservable +C infinite eigenvalues of the pencil A - lambda*E. +C For JOBOBS = 'F' or 'I', NIUOBS has no significance +C and is set to zero. +C +C NLBLCK (output) INTEGER +C For JOBOBS = 'O' or 'I', the number k, of full column rank +C _ +C blocks Ei-1,i in the staircase form of the pencil +C (Eo-lambda*Ao) (see (1) and (2)). +C ( Co ) +C For JOBOBS = 'F', the number k, of full column rank blocks +C _ +C Ai-1,i in the staircase form of the pencil (Ao-lambda*Eo) +C ( Co ) +C (see (3) and (4)). +C +C CTAU (output) INTEGER array, dimension (N) +C CTAU(i), for i = 1, ..., NLBLCK, is the column dimension +C _ _ +C of the full column rank block Ei-1,i or Ai-1,i in the +C staircase form (1) or (3) for JOBOBS = 'O' or 'I', or +C for JOBOBS = 'F', respectively. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determinations when +C transforming (A'-lambda*E',C')'. If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C reciprocal condition numbers in rank determinations; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where EPS +C is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension (P) +C +C DWORK DOUBLE PRECISION array, dimension MAX(N,2*P) +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the dual of the reduction +C algorithms of [1]. +C +C REFERENCES +C +C [1] A. Varga +C Computation of Irreducible Generalized State-Space +C Realizations. +C Kybernetika, vol. 26, pp. 89-106, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( N**3 ) floating point operations. +C +C FURTHER COMMENTS +C +C If the system matrices A, E and C are badly scaled, it is +C generally recommendable to scale them with the SLICOT routine +C TG01AD, before calling TG01ID. +C +C CONTRIBUTOR +C +C C. Oara, University "Politehnica" Bucharest. +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C March 1999. Based on the RASP routine RPDSCF. +C +C REVISIONS +C +C July 1999, V. Sima, Research Institute for Informatics, Bucharest. +C May 2003, March 2004, V. Sima. +C +C KEYWORDS +C +C Observability, minimal realization, orthogonal canonical form, +C orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +C .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOBOBS + INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDZ, + $ M, N, NIUOBS, NLBLCK, NOBSV, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER CTAU( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ DWORK( * ), E( LDE, * ), Q( LDQ, * ), + $ Z( LDZ, * ) +C .. Local Scalars .. + CHARACTER JOBQ, JOBZ + LOGICAL FINOBS, ILQ, ILZ, INFOBS + INTEGER I, ICOMPQ, ICOMPZ, LBA, LBE, NR +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL AB07MD, DSWAP, MA02BD, MA02CD, TB01XD, + $ TG01HX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable Statements .. +C +C Decode JOBOBS. +C + IF( LSAME( JOBOBS, 'O') ) THEN + FINOBS = .TRUE. + INFOBS = .TRUE. + ELSE IF( LSAME( JOBOBS, 'F') ) THEN + FINOBS = .TRUE. + INFOBS = .FALSE. + ELSE IF( LSAME( JOBOBS, 'I') ) THEN + FINOBS = .FALSE. + INFOBS = .TRUE. + ELSE + FINOBS = .FALSE. + INFOBS = .FALSE. + END IF +C +C Decode COMPQ. +C + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'U' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +C +C Decode COMPZ. +C + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'U' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +C +C Test the input scalar parameters. +C + INFO = 0 + IF( .NOT.FINOBS .AND. .NOT.INFOBS ) THEN + INFO = -1 + ELSE IF( ICOMPQ.LE.0 ) THEN + INFO = -2 + ELSE IF( ICOMPZ.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -10 + ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN + INFO = -12 + ELSE IF( LDC.LT.MAX( 1, M, P ) ) THEN + INFO = -14 + ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN + INFO = -16 + ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN + INFO = -18 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -23 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'TG01ID', -INFO ) + RETURN + END IF +C + JOBQ = COMPQ + JOBZ = COMPZ +C +C Build the dual system. +C + CALL AB07MD( 'Z', N, M, P, A, LDA, B, LDB, C, LDC, DUM, 1, + $ INFO ) + DO 10 I = 2, N + CALL DSWAP( I-1, E(I,1), LDE, E(1,I), 1 ) + 10 CONTINUE +C + IF( FINOBS ) THEN +C +C Perform finite observability form reduction. +C + CALL TG01HX( JOBZ, JOBQ, N, N, P, M, N, MAX( 0, N-1 ), A, LDA, + $ E, LDE, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NR, + $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) + IF( NLBLCK.GT.1 ) THEN + LBA = CTAU(1) + CTAU(2) - 1 + ELSE IF( NLBLCK.EQ.1 ) THEN + LBA = CTAU(1) - 1 + ELSE + LBA = 0 + END IF + IF( ILQ ) JOBQ = 'U' + IF( ILZ ) JOBZ = 'U' + LBE = 0 + ELSE + NR = N + LBA = MAX( 0, N-1 ) + LBE = LBA + END IF +C + IF( INFOBS ) THEN +C +C Perform infinite observability form reduction. +C + CALL TG01HX( JOBZ, JOBQ, N, N, P, M, NR, LBA, E, LDE, + $ A, LDA, B, LDB, C, LDC, Z, LDZ, Q, LDQ, NOBSV, + $ NLBLCK, CTAU, TOL, IWORK, DWORK, INFO ) + IF( FINOBS ) THEN + NIUOBS = NR - NOBSV + ELSE + NIUOBS = 0 + END IF + IF( NLBLCK.GT.1 ) THEN + LBE = CTAU(1) + CTAU(2) - 1 + ELSE IF( NLBLCK.EQ.1 ) THEN + LBE = CTAU(1) - 1 + ELSE + LBE = 0 + END IF + LBA = 0 + ELSE + NOBSV = NR + NIUOBS = 0 + END IF +C +C Compute the pertransposed dual system exploiting matrix shapes. +C + LBA = MAX( LBA, NIUOBS-1, N-NOBSV-NIUOBS-1 ) + IF ( P.EQ.0 .OR. NR.EQ.0 ) + $ LBE = MAX( 0, N - 1 ) + CALL TB01XD( 'Z', N, P, M, LBA, MAX( 0, N-1 ), A, LDA, B, LDB, + $ C, LDC, DUM, 1, INFO ) + CALL MA02CD( N, LBE, MAX( 0, N-1 ), E, LDE ) + IF( ILZ ) CALL MA02BD( 'Right', N, N, Z, LDZ ) + IF( ILQ ) CALL MA02BD( 'Right', N, N, Q, LDQ ) + RETURN +C *** Last line of TG01ID *** + END diff --git a/mex/sources/libslicot/TG01JD.f b/mex/sources/libslicot/TG01JD.f new file mode 100644 index 000000000..93cecec4e --- /dev/null +++ b/mex/sources/libslicot/TG01JD.f @@ -0,0 +1,613 @@ + SUBROUTINE TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE, + $ B, LDB, C, LDC, NR, INFRED, TOL, IWORK, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To find a reduced (controllable, observable, or irreducible) +C descriptor representation (Ar-lambda*Er,Br,Cr) for an original +C descriptor representation (A-lambda*E,B,C). +C The pencil Ar-lambda*Er is in an upper block Hessenberg form, with +C either Ar or Er upper triangular. +C +C ARGUMENTS +C +C Mode Parameters +C +C JOB CHARACTER*1 +C Indicates whether the user wishes to remove the +C uncontrollable and/or unobservable parts as follows: +C = 'I': Remove both the uncontrollable and unobservable +C parts to get an irreducible descriptor +C representation; +C = 'C': Remove the uncontrollable part only to get a +C controllable descriptor representation; +C = 'O': Remove the unobservable part only to get an +C observable descriptor representation. +C +C SYSTYP CHARACTER*1 +C Indicates the type of descriptor system algorithm +C to be applied according to the assumed +C transfer-function matrix as follows: +C = 'R': Rational transfer-function matrix; +C = 'S': Proper (standard) transfer-function matrix; +C = 'P': Polynomial transfer-function matrix. +C +C EQUIL CHARACTER*1 +C Specifies whether the user wishes to preliminarily scale +C the system (A-lambda*E,B,C) as follows: +C = 'S': Perform scaling; +C = 'N': Do not perform scaling. +C +C Input/Output Parameters +C +C N (input) INTEGER +C The dimension of the descriptor state vector; also the +C order of square matrices A and E, the number of rows of +C matrix B, and the number of columns of matrix C. N >= 0. +C +C M (input) INTEGER +C The dimension of descriptor system input vector; also the +C number of columns of matrix B. M >= 0. +C +C P (input) INTEGER +C The dimension of descriptor system output vector; also the +C number of rows of matrix C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state matrix A. +C On exit, the leading NR-by-NR part of this array contains +C the reduced order state matrix Ar of an irreducible, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'I', +C JOB = 'C', or JOB = 'O', respectively. +C The matrix Ar is upper triangular if SYSTYP = 'R' or 'P'. +C If SYSTYP = 'S' and JOB = 'C', the matrix [Br Ar] +C is in a controllable staircase form (see TG01HD). +C If SYSTYP = 'S' and JOB = 'I' or 'O', the matrix ( Ar ) +C ( Cr ) +C is in an observable staircase form (see TG01HD). +C The block structure of staircase forms is contained +C in the leading INFRED(7) elements of IWORK. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the original descriptor matrix E. +C On exit, the leading NR-by-NR part of this array contains +C the reduced order descriptor matrix Er of an irreducible, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'I', +C JOB = 'C', or JOB = 'O', respectively. +C The resulting Er has INFRED(6) nonzero sub-diagonals. +C If at least for one k = 1,...,4, INFRED(k) >= 0, then the +C resulting Er is structured being either upper triangular +C or block Hessenberg, in accordance to the last +C performed order reduction phase (see METHOD). +C The block structure of staircase forms is contained +C in the leading INFRED(7) elements of IWORK. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M), +C if JOB = 'C', or (LDB,MAX(M,P)), otherwise. +C On entry, the leading N-by-M part of this array must +C contain the original input matrix B; if JOB = 'I', +C or JOB = 'O', the remainder of the leading N-by-MAX(M,P) +C part is used as internal workspace. +C On exit, the leading NR-by-M part of this array contains +C the reduced input matrix Br of an irreducible, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'I', +C JOB = 'C', or JOB = 'O', respectively. +C If JOB = 'C', only the first IWORK(1) rows of B are +C nonzero. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the original output matrix C; if JOB = 'I', +C or JOB = 'O', the remainder of the leading MAX(M,P)-by-N +C part is used as internal workspace. +C On exit, the leading P-by-NR part of this array contains +C the transformed state/output matrix Cr of an irreducible, +C controllable, or observable realization for the original +C system, depending on the value of JOB, JOB = 'I', +C JOB = 'C', or JOB = 'O', respectively. +C If JOB = 'I', or JOB = 'O', only the last IWORK(1) columns +C (in the first NR columns) of C are nonzero. +C +C LDC INTEGER +C The leading dimension of array C. +C LDC >= MAX(1,M,P) if N > 0. +C LDC >= 1 if N = 0. +C +C NR (output) INTEGER +C The order of the reduced descriptor representation +C (Ar-lambda*Er,Br,Cr) of an irreducible, controllable, +C or observable realization for the original system, +C depending on JOB = 'I', JOB = 'C', or JOB = 'O', +C respectively. +C +C INFRED (output) INTEGER array, dimension 7 +C This array contains information on performed reduction +C and on structure of resulting system matrices as follows: +C INFRED(k) >= 0 (k = 1, 2, 3, or 4) if Phase k of reduction +C (see METHOD) has been performed. In this +C case, INFRED(k) is the achieved order +C reduction in Phase k. +C INFRED(k) < 0 (k = 1, 2, 3, or 4) if Phase k was not +C performed. +C INFRED(5) - the number of nonzero sub-diagonals of A. +C INFRED(6) - the number of nonzero sub-diagonals of E. +C INFRED(7) - the number of blocks in the resulting +C staircase form at last performed reduction +C phase. The block dimensions are contained +C in the first INFRED(7) elements of IWORK. +C +C Tolerances +C +C TOL DOUBLE PRECISION +C The tolerance to be used in rank determinations when +C transforming (A-lambda*E,B,C). If the user sets TOL > 0, +C then the given value of TOL is used as a lower bound for +C reciprocal condition numbers in rank determinations; a +C (sub)matrix whose estimated condition number is less than +C 1/TOL is considered to be of full rank. If the user sets +C TOL <= 0, then an implicitly computed, default tolerance, +C defined by TOLDEF = N*N*EPS, is used instead, where +C EPS is the machine precision (see LAPACK Library routine +C DLAMCH). TOL < 1. +C +C Workspace +C +C IWORK INTEGER array, dimension N+MAX(M,P) +C On exit, if INFO = 0, the leading INFRED(7) elements of +C IWORK contain the orders of the diagonal blocks of +C Ar-lambda*Er. +C +C DWORK DOUBLE PRECISION array, dimension LDWORK +C +C LDWORK INTEGER +C The length of the array DWORK. +C LDWORK >= MAX(8*N,2*M,2*P), if EQUIL = 'S'; +C LDWORK >= MAX(N,2*M,2*P), if EQUIL = 'N'. +C If LDWORK >= MAX(2*N*N+N*M+N*P)+MAX(N,2*M,2*P) then more +C accurate results are to be expected by performing only +C those reductions phases (see METHOD), where effective +C order reduction occurs. This is achieved by saving the +C system matrices before each phase and restoring them if no +C order reduction took place. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The subroutine is based on the reduction algorithms of [1]. +C The order reduction is performed in 4 phases: +C Phase 1: Eliminate all finite uncontrolable eigenvalues. +C The resulting matrix ( Br Ar ) is in a controllable +C staircase form (see SLICOT Library routine TG01HD), and +C Er is upper triangular. +C This phase is performed if JOB = 'I' or 'C' and +C SYSTYP = 'R' or 'S'. +C Phase 2: Eliminate all infinite and finite nonzero uncontrollable +C eigenvalues. The resulting matrix ( Br Er ) is in a +C controllable staircase form (see TG01HD), and Ar is +C upper triangular. +C This phase is performed if JOB = 'I' or 'C' and +C SYSTYP = 'R' or 'P'. +C Phase 3: Eliminate all finite unobservable eigenvalues. +C The resulting matrix ( Ar ) is in an observable +C ( Cr ) +C staircase form (see SLICOT Library routine TG01ID), and +C Er is upper triangular. +C This phase is performed if JOB = 'I' or 'O' and +C SYSTYP = 'R' or 'S'. +C Phase 4: Eliminate all infinite and finite nonzero unobservable +C eigenvalues. The resulting matrix ( Er ) is in an +C ( Cr ) +C observable staircase form (see TG01ID), and Ar is +C upper triangular. +C This phase is performed if JOB = 'I' or 'O' and +C SYSTYP = 'R' or 'P'. +C +C REFERENCES +C +C [1] A. Varga +C Computation of Irreducible Generalized State-Space +C Realizations. +C Kybernetika, vol. 26, pp. 89-106, 1990. +C +C NUMERICAL ASPECTS +C +C The algorithm is numerically backward stable and requires +C 0( N**3 ) floating point operations. +C +C FURTHER COMMENTS +C +C If the pencil (A-lambda*E) has no zero eigenvalues, then an +C irreducible realization can be computed skipping Phases 1 and 3 +C by using the setting: JOB = 'I' and SYSTYP = 'P'. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C April 1999. Based on the RASP routine RPDSIR. +C +C REVISIONS +C +C July 1999, V. Sima, Research Institute for Informatics, Bucharest. +C May 2003, A. Varga, German Aerospace Center, DLR Oberpfaffenhofen. +C May 2003, March 2004, V. Sima. +C +C KEYWORDS +C +C Controllability, irreducible realization, observability, +C orthogonal canonical form, orthogonal transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) +C .. Scalar Arguments .. + CHARACTER EQUIL, JOB, SYSTYP + INTEGER INFO, LDA, LDB, LDC, LDE, LDWORK, M, N, NR, P + DOUBLE PRECISION TOL +C .. Array Arguments .. + INTEGER INFRED(*), IWORK(*) + DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), E(LDE,*) +C .. Local Scalars .. + CHARACTER JOBQ, JOBZ + LOGICAL FINCON, FINOBS, INFCON, INFOBS, LEQUIL, LJOBC, + $ LJOBIR, LJOBO, LSPACE, LSYSP, LSYSR, LSYSS + INTEGER KWA, KWB, KWC, KWE, LBA, LBE, LDM, LDP, LDQ, + $ LDZ, M1, MAXMP, N1, NBLCK, NC, P1 +C .. Local Arrays .. + DOUBLE PRECISION DUM(1) +C .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +C .. External Subroutines .. + EXTERNAL DLACPY, MA02CD, TB01XD, TG01AD, TG01HX, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C .. Executable Statements .. +C + INFO = 0 + MAXMP = MAX( M, P ) + N1 = MAX( 1, N ) +C +C Decode JOB. +C + LJOBIR = LSAME( JOB, 'I' ) + LJOBC = LJOBIR .OR. LSAME( JOB, 'C' ) + LJOBO = LJOBIR .OR. LSAME( JOB, 'O' ) +C +C Decode SYSTYP. +C + LSYSR = LSAME( SYSTYP, 'R' ) + LSYSS = LSYSR .OR. LSAME( SYSTYP, 'S' ) + LSYSP = LSYSR .OR. LSAME( SYSTYP, 'P' ) +C + LEQUIL = LSAME( EQUIL, 'S' ) +C +C Test the input scalar arguments. +C + IF( .NOT.LJOBC .AND. .NOT.LJOBO ) THEN + INFO = -1 + ELSE IF( .NOT.LSYSS .AND. .NOT.LSYSP ) THEN + INFO = -2 + ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -5 + ELSE IF( P.LT.0 ) THEN + INFO = -6 + ELSE IF( LDA.LT.N1 ) THEN + INFO = -8 + ELSE IF( LDE.LT.N1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.N1 ) THEN + INFO = -12 + ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN + INFO = -14 + ELSE IF( TOL.GE.ONE ) THEN + INFO = -17 + ELSE IF( ( .NOT.LEQUIL .AND. LDWORK.LT.MAX( N, 2*MAXMP ) ) .OR. + $ ( LEQUIL .AND. LDWORK.LT.MAX( 8*N, 2*MAXMP ) ) ) THEN + INFO = -20 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TG01JD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + INFRED(1) = -1 + INFRED(2) = -1 + INFRED(3) = -1 + INFRED(4) = -1 + INFRED(5) = 0 + INFRED(6) = 0 + INFRED(7) = 0 +C + IF( MAX( N, MAXMP ).EQ.0 ) THEN + NR = 0 + RETURN + END IF +C + M1 = MAX( 1, M ) + P1 = MAX( 1, P ) + LDM = MAX( LDC, M ) + LDP = MAX( LDC, P ) +C +C Set controllability/observability determination options. +C + FINCON = LJOBC .AND. LSYSS + INFCON = LJOBC .AND. LSYSP + FINOBS = LJOBO .AND. LSYSS + INFOBS = LJOBO .AND. LSYSP +C +C Set large workspace option and determine offsets. +C + LSPACE = LDWORK.GE.N*( 2*N + M + P ) + MAX( N, 2*MAXMP ) + KWA = MAX( N, 2*MAXMP ) + 1 + KWE = KWA + N*N + KWB = KWE + N*N + KWC = KWB + N*M +C +C If required, scale the system (A-lambda*E,B,C). +C Workspace: need 8*N. +C + IF( LEQUIL ) THEN + CALL TG01AD( 'All', N, N, M, P, ZERO, A, LDA, E, LDE, B, LDB, + $ C, LDP, DWORK(1), DWORK(N+1), DWORK(2*N+1), INFO ) + END IF +C + JOBQ = 'N' + JOBZ = 'N' + LDQ = 1 + LDZ = 1 + LBA = MAX( 0, N-1 ) + LBE = LBA + NC = N + NR = N +C + IF( FINCON ) THEN +C +C Phase 1: Eliminate all finite uncontrolable eigenvalues. +C + IF( LSPACE) THEN +C +C Save system matrices. +C + CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) + CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) + CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) + CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) + END IF +C +C Perform finite controllability form reduction. +C Workspace: need MAX(N,2*M). +C + CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBE, A, LDA, + $ E, LDE, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, + $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) + IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN + IF( NBLCK.GT.1 ) THEN + LBA = IWORK(1) + IWORK(2) - 1 + ELSE IF( NBLCK.EQ.1 ) THEN + LBA = IWORK(1) - 1 + ELSE + LBA = 0 + END IF + LBE = 0 + INFRED(1) = NC - NR + INFRED(7) = NBLCK + NC = NR + ELSE +C +C Restore system matrices. +C + CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) + CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) + CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) + CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) + END IF + END IF +C + IF( INFCON ) THEN +C +C Phase 2: Eliminate all infinite and all finite nonzero +C uncontrolable eigenvalues. +C + IF( LSPACE ) THEN +C +C Save system matrices. +C + CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) + CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) + CALL DLACPY( 'Full', NC, M, B, LDB, DWORK(KWB), N1 ) + CALL DLACPY( 'Full', P, NC, C, LDC, DWORK(KWC), P1 ) + END IF +C +C Perform infinite controllability form reduction. +C Workspace: need MAX(N,2*M). +C + CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBA, E, LDE, + $ A, LDA, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR, + $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) + IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN + IF( NBLCK.GT.1 ) THEN + LBE = IWORK(1) + IWORK(2) - 1 + ELSE IF( NBLCK.EQ.1 ) THEN + LBE = IWORK(1) - 1 + ELSE + LBE = 0 + END IF + LBA = 0 + INFRED(2) = NC - NR + INFRED(7) = NBLCK + NC = NR + ELSE +C +C Restore system matrices. +C + CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) + CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) + CALL DLACPY( 'Full', NC, M, DWORK(KWB), N1, B, LDB ) + CALL DLACPY( 'Full', P, NC, DWORK(KWC), P1, C, LDC ) + END IF + END IF +C + IF( FINOBS .OR. INFOBS) THEN +C +C Compute the pertransposed dual system exploiting matrix shapes. +C + CALL TB01XD( 'Z', NC, M, P, LBA, MAX( 0, NC-1 ), A, LDA, + $ B, LDB, C, LDC, DUM, 1, INFO ) + CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) + END IF +C + IF( FINOBS ) THEN +C +C Phase 3: Eliminate all finite unobservable eigenvalues. +C + IF( LSPACE ) THEN +C +C Save system matrices. +C + CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) + CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) + CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) + CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) + END IF +C +C Perform finite observability form reduction. +C Workspace: need MAX(N,2*P). +C + CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBE, A, LDA, + $ E, LDE, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, + $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) + IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN + IF( NBLCK.GT.1 ) THEN + LBA = IWORK(1) + IWORK(2) - 1 + ELSE IF( NBLCK.EQ.1 ) THEN + LBA = IWORK(1) - 1 + ELSE + LBA = 0 + END IF + LBE = 0 + INFRED(3) = NC - NR + INFRED(7) = NBLCK + NC = NR + ELSE +C +C Restore system matrices. +C + CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) + CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) + CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) + CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) + END IF + END IF +C + IF( INFOBS ) THEN +C +C Phase 4: Eliminate all infinite and all finite nonzero +C unobservable eigenvalues. +C + IF( LSPACE) THEN +C +C Save system matrices. +C + CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 ) + CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 ) + CALL DLACPY( 'Full', NC, P, B, LDB, DWORK(KWC), N1 ) + CALL DLACPY( 'Full', M, NC, C, LDC, DWORK(KWB), M1 ) + END IF +C +C Perform infinite observability form reduction. +C Workspace: need MAX(N,2*P). +C + CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBA, E, LDE, + $ A, LDA, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR, + $ NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO ) + IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN + IF( NBLCK.GT.1 ) THEN + LBE = IWORK(1) + IWORK(2) - 1 + ELSE IF( NBLCK.EQ.1 ) THEN + LBE = IWORK(1) - 1 + ELSE + LBE = 0 + END IF + LBA = 0 + INFRED(4) = NC - NR + INFRED(7) = NBLCK + NC = NR + ELSE +C +C Restore system matrices. +C + CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA ) + CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE ) + CALL DLACPY( 'Full', NC, P, DWORK(KWC), N1, B, LDB ) + CALL DLACPY( 'Full', M, NC, DWORK(KWB), M1, C, LDC ) + END IF + END IF +C + IF( FINOBS .OR. INFOBS ) THEN +C +C Compute the pertransposed dual system exploiting matrix shapes. +C + CALL TB01XD( 'Z', NC, P, M, LBA, MAX( 0, NC-1 ), A, LDA, + $ B, LDB, C, LDC, DUM, 1, INFO ) + CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE ) + END IF +C +C Set structural information on A and E. +C + INFRED(5) = LBA + INFRED(6) = LBE +C + RETURN +C *** Last line of TG01JD *** + END diff --git a/mex/sources/libslicot/TG01WD.f b/mex/sources/libslicot/TG01WD.f new file mode 100644 index 000000000..26d06848e --- /dev/null +++ b/mex/sources/libslicot/TG01WD.f @@ -0,0 +1,319 @@ + SUBROUTINE TG01WD( N, M, P, A, LDA, E, LDE, B, LDB, C, LDC, + $ Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK, + $ LDWORK, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To reduce the pair (A,E) to a real generalized Schur form +C by using an orthogonal equivalence transformation +C (A,E) <-- (Q'*A*Z,Q'*E*Z) and to apply the transformation +C to the matrices B and C: B <-- Q'*B and C <-- C*Z. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C N (input) INTEGER +C The order of the original state-space representation, +C i.e., the order of the matrices A and E. N >= 0. +C +C M (input) INTEGER +C The number of system inputs, or of columns of B. M >= 0. +C +C P (input) INTEGER +C The number of system outputs, or of rows of C. P >= 0. +C +C A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +C On entry, the leading N-by-N part of this array must +C contain the original state dynamics matrix A. +C On exit, the leading N-by-N part of this array contains +C the matrix Q' * A * Z in an upper quasi-triangular form. +C The elements below the first subdiagonal are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,N). +C +C E (input/output) DOUBLE PRECISION array, dimension (LDE,N) +C On entry, the leading N-by-N part of this array must +C contain the original descriptor matrix E. +C On exit, the leading N-by-N part of this array contains +C the matrix Q' * E * Z in an upper triangular form. +C The elements below the diagonal are set to zero. +C +C LDE INTEGER +C The leading dimension of array E. LDE >= MAX(1,N). +C +C B (input/output) DOUBLE PRECISION array, dimension (LDB,M) +C On entry, the leading N-by-M part of this array must +C contain the input matrix B. +C On exit, the leading N-by-M part of this array contains +C the transformed input matrix Q' * B. +C +C LDB INTEGER +C The leading dimension of array B. LDB >= MAX(1,N). +C +C C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +C On entry, the leading P-by-N part of this array must +C contain the output matrix C. +C On exit, the leading P-by-N part of this array contains +C the transformed output matrix C * Z. +C +C LDC INTEGER +C The leading dimension of array C. LDC >= MAX(1,P). +C +C Q (output) DOUBLE PRECISION array, dimension (LDQ,N) +C The leading N-by-N part of this array contains the left +C orthogonal transformation matrix used to reduce (A,E) to +C the real generalized Schur form. +C The columns of Q are the left generalized Schur vectors +C of the pair (A,E). +C +C LDQ INTEGER +C The leading dimension of array Q. LDQ >= max(1,N). +C +C Z (output) DOUBLE PRECISION array, dimension (LDZ,N) +C The leading N-by-N part of this array contains the right +C orthogonal transformation matrix used to reduce (A,E) to +C the real generalized Schur form. +C The columns of Z are the right generalized Schur vectors +C of the pair (A,E). +C +C LDZ INTEGER +C The leading dimension of array Z. LDZ >= max(1,N). +C +C ALPHAR (output) DOUBLE PRECISION array, dimension (N) +C ALPHAI (output) DOUBLE PRECISION array, dimension (N) +C BETA (output) DOUBLE PRECISION array, dimension (N) +C On exit, if INFO = 0, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), +C j=1,...,N, will be the generalized eigenvalues. +C ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j=1,...,N, are the +C diagonals of the complex Schur form that would result if +C the 2-by-2 diagonal blocks of the real Schur form of +C (A,E) were further reduced to triangular form using +C 2-by-2 complex unitary transformations. +C If ALPHAI(j) is zero, then the j-th eigenvalue is real; +C if positive, then the j-th and (j+1)-st eigenvalues are a +C complex conjugate pair, with ALPHAI(j+1) negative. +C +C Workspace +C +C DWORK DOUBLE PRECISION array, dimension (LDWORK) +C On exit, if INFO = 0, DWORK(1) returns the optimal value +C of LDWORK. +C +C LDWORK INTEGER +C The dimension of working array DWORK. LDWORK >= 8*N+16. +C For optimum performance LDWORK should be larger. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C > 0: if INFO = i, the QZ algorithm failed to compute +C the generalized real Schur form; elements i+1:N of +C ALPHAR, ALPHAI, and BETA should be correct. +C +C METHOD +C +C The pair (A,E) is reduced to a real generalized Schur form using +C an orthogonal equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z) +C and the transformation is applied to the matrices B and C: +C B <-- Q'*B and C <-- C*Z. +C +C NUMERICAL ASPECTS +C 3 +C The algorithm requires about 25N floating point operations. +C +C CONTRIBUTOR +C +C A. Varga, German Aerospace Center, +C DLR Oberpfaffenhofen, July 2000. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001. +C +C KEYWORDS +C +C Orthogonal transformation, generalized real Schur form, similarity +C transformation. +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, + $ M, N, P +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*), + $ BETA(*), C(LDC,*), DWORK(*), E(LDE,*), + $ Q(LDQ,*), Z(LDZ,*) +C .. Local Scalars .. + LOGICAL BLAS3, BLOCK + INTEGER BL, CHUNK, I, J, MAXWRK, SDIM +C .. Local Arrays .. + LOGICAL BWORK(1) +C .. External Functions .. + LOGICAL LSAME, DELCTG + EXTERNAL LSAME, DELCTG +C .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DGEMV, DGGES, DLACPY, XERBLA +C .. Intrinsic Functions .. + INTRINSIC DBLE, INT, MAX, MIN +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check the scalar input parameters. +C + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 ) THEN + INFO = -2 + ELSE IF( P.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE IF( LDC.LT.MAX( 1, P ) ) THEN + INFO = -11 + ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDWORK.LT.8*N+16 ) THEN + INFO = -20 + END IF +C + IF( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'TG01WD', -INFO ) + RETURN + END IF +C +C Quick return if possible. +C + IF( N.EQ.0 ) THEN + DWORK(1) = ONE + RETURN + END IF +C +C Reduce (A,E) to real generalized Schur form using an orthogonal +C equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z), accumulate +C the transformations in Q and Z, and compute the generalized +C eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA). +C +C Workspace: need 8*N+16; +C prefer larger. +C + CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N, + $ A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, + $ Z, LDZ, DWORK, LDWORK, BWORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN + MAXWRK = INT( DWORK(1) ) +C +C Apply the transformation: B <-- Q'*B. Use BLAS 3, if enough space. +C + CHUNK = LDWORK / N + BLOCK = M.GT.1 + BLAS3 = CHUNK.GE.M .AND. BLOCK +C + IF( BLAS3 ) THEN +C +C Enough workspace for a fast BLAS 3 algorithm. +C + CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, Q, LDQ, + $ DWORK, N, ZERO, B, LDB ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many columns of B as possible. +C + DO 10 J = 1, M, CHUNK + BL = MIN( M-J+1, CHUNK ) + CALL DLACPY( 'Full', N, BL, B(1,J), LDB, DWORK, N ) + CALL DGEMM( 'Transpose', 'NoTranspose', N, BL, N, ONE, Q, + $ LDQ, DWORK, N, ZERO, B(1,J), LDB ) + 10 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. Here, M <= 1. +C + IF ( M.GT.0 ) THEN + CALL DCOPY( N, B, 1, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, ZERO, + $ B, 1 ) + END IF + END IF + MAXWRK = MAX( MAXWRK, N*M ) +C +C Apply the transformation: C <-- C*Z. Use BLAS 3, if enough space. +C + BLOCK = P.GT.1 + BLAS3 = CHUNK.GE.P .AND. BLOCK +C + IF ( BLAS3 ) THEN + CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P ) + CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, + $ DWORK, P, Z, LDZ, ZERO, C, LDC ) +C + ELSE IF ( BLOCK ) THEN +C +C Use as many rows of C as possible. +C + DO 20 I = 1, P, CHUNK + BL = MIN( P-I+1, CHUNK ) + CALL DLACPY( 'Full', BL, N, C(I,1), LDC, DWORK, BL ) + CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE, + $ DWORK, BL, Z, LDZ, ZERO, C(I,1), LDC ) + 20 CONTINUE +C + ELSE +C +C Use a BLAS 2 algorithm. Here, P <= 1. +C + IF ( P.GT.0 ) THEN + CALL DCOPY( N, C, LDC, DWORK, 1 ) + CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, ZERO, + $ C, LDC ) + END IF +C + END IF + MAXWRK = MAX( MAXWRK, P*N ) +C + DWORK(1) = DBLE( MAXWRK ) +C + RETURN +C *** Last line of TG01WD *** + END diff --git a/mex/sources/libslicot/UD01BD.f b/mex/sources/libslicot/UD01BD.f new file mode 100644 index 000000000..256984c17 --- /dev/null +++ b/mex/sources/libslicot/UD01BD.f @@ -0,0 +1,149 @@ + SUBROUTINE UD01BD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To read the coefficients of a matrix polynomial +C dp-1 dp +C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the matrix polynomial P(s). +C MP >= 1. +C +C NP (input) INTEGER +C The number of columns of the matrix polynomial P(s). +C NP >= 1. +C +C DP (input) INTEGER +C The degree of the matrix polynomial P(s). DP >= 0. +C +C NIN (input) INTEGER +C The input channel from which the elements of P(s) are +C read. NIN >= 0. +C +C P (output) DOUBLE PRECISION array, dimension +C (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array contains +C the coefficients of the matrix polynomial P(s). +C Specifically, P(i,j,k) contains the coefficient of +C s**(k-1) of the polynomial which is the (i,j)-th element +C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and +C k = 1,2,...,DP+1. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MP. +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= NP. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The coefficients P(i), i = 0, ..., DP, which are MP-by-NP +C matrices, are read from the input file NIN row by row. Each P(i) +C must be preceded by a text line. This text line can be used to +C indicate the coefficient matrices. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on routine RDMAPO by A.J. Geurts, Eindhoven University of +C Technology, Holland. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN +C .. Array Arguments .. + DOUBLE PRECISION P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER I, J, K +C .. External Subroutines .. + EXTERNAL XERBLA +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check the input scalar arguments. +C + IF( MP.LT.1 ) THEN + INFO = -1 + ELSE IF( NP.LT.1 ) THEN + INFO = -2 + ELSE IF( DP.LT.0 ) THEN + INFO = -3 + ELSE IF( NIN.LT.0 ) THEN + INFO = -4 + ELSE IF( LDP1.LT.MP ) THEN + INFO = -6 + ELSE IF( LDP2.LT.NP ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01BD', -INFO ) + RETURN + END IF +C +C Skip the text line preceding P(i) and read P(i), i = 0, ..., DP, +C row after row. +C + DO 20 K = 1, DP + 1 + READ ( NIN, FMT = '()' ) +C + DO 10 I = 1, MP + READ ( NIN, FMT = * ) ( P(I,J,K), J = 1, NP ) + 10 CONTINUE +C + 20 CONTINUE +C + RETURN +C *** Last line of UD01BD *** + END diff --git a/mex/sources/libslicot/UD01CD.f b/mex/sources/libslicot/UD01CD.f new file mode 100644 index 000000000..52a104558 --- /dev/null +++ b/mex/sources/libslicot/UD01CD.f @@ -0,0 +1,174 @@ + SUBROUTINE UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To read the elements of a sparse matrix polynomial +C dp-1 dp +C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the matrix polynomial P(s). +C MP >= 1. +C +C NP (input) INTEGER +C The number of columns of the matrix polynomial P(s). +C NP >= 1. +C +C DP (input) INTEGER +C The degree of the matrix polynomial P(s). DP >= 0. +C +C NIN (input) INTEGER +C The input channel from which the elements of P(s) are +C read. NIN >= 0. +C +C P (output) DOUBLE PRECISION array, dimension +C (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array contains +C the coefficients of the matrix polynomial P(s). +C Specifically, P(i,j,k) contains the coefficient of +C s**(k-1) of the polynomial which is the (i,j)-th element +C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and +C k = 1,2,...,DP+1. +C The not assigned elements are set to zero. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MP. +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= NP. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1 : if a row index i is read with i < 1 or i > MP or +C a column index j is read with j < 1 or j > NP or +C a coefficient degree d is read with d < 0 or +C d > DP + 1. This is a warning. +C +C METHOD +C +C First, the elements P(i,j,k) with 1 <= i <= MP, 1 <= j <= NP and +C 1 <= k <= DP + 1 are set to zero. Next the nonzero (polynomial) +C elements are read from the input file NIN. Each nonzero element is +C given by the values i, j, d, P(i,j,k), k = 1, ..., d+1, where d is +C the degree and P(i,j,k) is the coefficient of s**(k-1) in the +C (i,j)-th element of P(s), i.e., let +C d +C P (s) = P (0) + P (1) * s + . . . + P (d) * s +C i,j i,j i,j i,j +C +C be the nonzero (i,j)-th element of the matrix polynomial P(s). +C +C Then P(i,j,k) corresponds to coefficient P (k-1), k = 1,...,d+1. +C i,j +C For each nonzero element, the values i, j, and d are read as one +C record of the file NIN, and the values P(i,j,k), k = 1,...,d+1, +C are read as the following record. +C The routine terminates after the last line has been read. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on routine RDSPOM by A.J. Geurts, Eindhoven University of +C Technology, Holland. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER DP, INFO, LDP1, LDP2, MP, NP, NIN +C .. Array Arguments .. + DOUBLE PRECISION P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER D, I, J, K +C .. External Subroutines .. + EXTERNAL DLASET, XERBLA +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check the input scalar arguments. +C + IF( MP.LT.1 ) THEN + INFO = -1 + ELSE IF( NP.LT.1 ) THEN + INFO = -2 + ELSE IF( DP.LT.0 ) THEN + INFO = -3 + ELSE IF( NIN.LT.0 ) THEN + INFO = -4 + ELSE IF( LDP1.LT.MP ) THEN + INFO = -6 + ELSE IF( LDP2.LT.NP ) THEN + INFO = -7 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01CD', -INFO ) + RETURN + END IF +C + DO 10 K = 1, DP+1 + CALL DLASET( 'Full', MP, NP, ZERO, ZERO, P(1,1,K), LDP1 ) + 10 CONTINUE +C +C Read (i, j, d, P(i,j,k), k=1,...,d+1) of the nonzero elements one +C by one. +C + 20 READ( NIN, FMT = *, END = 30 ) I, J, D + IF ( I.LT.1 .OR. I.GT.MP .OR. J.LT.1 .OR. J.GT.NP .OR. + $ D.LT.0 .OR. D.GT.(DP+1) ) THEN + INFO = 1 + READ ( NIN, FMT = * ) + ELSE + READ ( NIN, FMT = * ) ( P(I,J,K), K = 1, D+1 ) + END IF + GO TO 20 +C + 30 CONTINUE + RETURN +C *** Last line of UD01CD *** + END diff --git a/mex/sources/libslicot/UD01DD.f b/mex/sources/libslicot/UD01DD.f new file mode 100644 index 000000000..d09cadbd3 --- /dev/null +++ b/mex/sources/libslicot/UD01DD.f @@ -0,0 +1,138 @@ + SUBROUTINE UD01DD( M, N, NIN, A, LDA, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To read the elements of a sparse matrix. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of the matrix A. M >= 0. +C +C N (input) INTEGER +C The number of columns of the matrix A. N >= 0. +C +C NIN (input) INTEGER +C The input channel from which the elements of A are read. +C NIN >= 0. +C +C A (output) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array contains the sparse +C matrix A. The not assigned elements are set to zero. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= MAX(1,M). +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value; +C = 1 : if a row index i is read with i < 1 or i > M or +C a column index j is read with j < 1 or j > N. +C This is a warning. +C +C METHOD +C +C First, the elements A(i,j) with 1 <= i <= M and 1 <= j <= N are +C set to zero. Next the nonzero elements are read from the input +C file NIN. Each line of NIN must contain consecutively the values +C i, j, A(i,j). The routine terminates after the last line has been +C read. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on routine RDSPAR by A.J. Geurts, Eindhoven University of +C Technology, Holland. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +C .. Scalar Arguments .. + INTEGER INFO, LDA, M, N, NIN +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AIJ +C .. External Subroutines .. + EXTERNAL DLASET, XERBLA +C .. Intrinsic Functions .. + INTRINSIC MAX +C +C .. Executable statements .. +C + INFO = 0 +C +C Check the input scalar arguments. +C + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NIN.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01DD', -INFO ) + RETURN + END IF +C + CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA ) +C +C Read (i, j, A(i,j)) of the nonzero elements one by one. +C + 10 READ( NIN, FMT = *, END = 20 ) I, J, AIJ + IF ( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN + INFO = 1 + ELSE + A(I,J) = AIJ + END IF + GO TO 10 + 20 CONTINUE +C + RETURN +C *** Last line of UD01DD *** + END diff --git a/mex/sources/libslicot/UD01MD.f b/mex/sources/libslicot/UD01MD.f new file mode 100644 index 000000000..a44e6545c --- /dev/null +++ b/mex/sources/libslicot/UD01MD.f @@ -0,0 +1,175 @@ + SUBROUTINE UD01MD( M, N, L, NOUT, A, LDA, TEXT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To print an M-by-N real matrix A row by row. The elements of A +C are output to 7 significant figures. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of matrix A to be printed. M >= 1. +C +C N (input) INTEGER +C The number of columns of matrix A to be printed. N >= 1. +C +C L (input) INTEGER +C The number of elements of matrix A to be printed per line. +C 1 <= L <= 5. +C +C NOUT (input) INTEGER +C The output channel to which the results are sent. +C NOUT >= 0. +C +C A (input) DOUBLE PRECISION array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix to be printed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= M. +C +C TEXT (input) CHARACTER*72. +C Title caption of the matrix to be printed (up to a +C maximum of 72 characters). For example, TEXT = 'Matrix A'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine first prints the contents of TEXT as a title, followed +C by the elements of the matrix A such that +C +C (i) if N <= L, the leading M-by-N part is printed; +C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of +C consecutive columns of A are printed one after another +C followed by one M-by-p block containing the last p columns +C of A. +C +C Row numbers are printed on the left of each row and a column +C number appears on top of each column. +C The routine uses 2 + (k + 1)*(m + 1) lines and 8 + 15*c positions +C per line where c is the actual number of columns, (i.e. c = L +C or c = p). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. +C Supersedes Release 2.0 routine UD01AD by H. Willemsen, Eindhoven +C University of Technology, Holland. +C +C REVISIONS +C +C V. Sima, Research Institute for Informatics, Bucharest, Jan. 2009. +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, M, N, NOUT + CHARACTER*(*) TEXT +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*) +C .. Local Scalars .. + INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC LEN, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( M.LT.1 ) THEN + INFO = -1 + ELSE IF( N.LT.1 ) THEN + INFO = -2 + ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN + INFO = -3 + ELSE IF( NOUT.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.M ) THEN + INFO = -6 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01MD', -INFO ) + RETURN + END IF +C + LENTXT = LEN( TEXT ) +C + DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 + IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 + 20 CONTINUE +C + 40 CONTINUE + WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N + N1 = ( N-1 )/L + J1 = 1 + J2 = L +C + DO 80 J = 1, N1 + WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) +C + DO 60 I = 1, M + WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) + 60 CONTINUE +C + WRITE ( NOUT, FMT=99998 ) + J1 = J1 + L + J2 = J2 + L + 80 CONTINUE +C + WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) +C + DO 100 I = 1, M + WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) + 100 CONTINUE +C + WRITE ( NOUT, FMT=99998 ) +C + RETURN +C +99999 FORMAT (8X,5(5X,I5,5X) ) +99998 FORMAT (' ' ) +99997 FORMAT (1X,I5,2X,5D15.7 ) +99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) +C *** Last line of UD01MD *** + END diff --git a/mex/sources/libslicot/UD01MZ.f b/mex/sources/libslicot/UD01MZ.f new file mode 100644 index 000000000..a9d83f706 --- /dev/null +++ b/mex/sources/libslicot/UD01MZ.f @@ -0,0 +1,175 @@ + SUBROUTINE UD01MZ( M, N, L, NOUT, A, LDA, TEXT, INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To print an M-by-N real matrix A row by row. The elements of A +C are output to 7 significant figures. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C M (input) INTEGER +C The number of rows of matrix A to be printed. M >= 1. +C +C N (input) INTEGER +C The number of columns of matrix A to be printed. N >= 1. +C +C L (input) INTEGER +C The number of elements of matrix A to be printed per line. +C 1 <= L <= 3. +C +C NOUT (input) INTEGER +C The output channel to which the results are sent. +C NOUT >= 0. +C +C A (input) COMPLEX*16 array, dimension (LDA,N) +C The leading M-by-N part of this array must contain the +C matrix to be printed. +C +C LDA INTEGER +C The leading dimension of array A. LDA >= M. +C +C TEXT (input) CHARACTER*72. +C Title caption of the matrix to be printed (up to a +C maximum of 72 characters). For example, TEXT = 'Matrix A'. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C The routine first prints the contents of TEXT as a title, followed +C by the elements of the matrix A such that +C +C (i) if N <= L, the leading M-by-N part is printed; +C (ii) if N = k*L + p (where k,p > 0), then k M-by-L blocks of +C consecutive columns of A are printed one after another +C followed by one M-by-p block containing the last p columns +C of A. +C +C Row numbers are printed on the left of each row and a column +C number appears on top of each complex column. +C The routine uses 2 + (k + 1)*(m + 1) lines and 7 + 32*c positions +C per line where c is the actual number of columns, (i.e. c = L +C or c = p). +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Oct. 1997. +C Complex version: V. Sima, Research Institute for Informatics, +C Bucharest, Dec. 2008. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER INFO, L, LDA, M, N, NOUT + CHARACTER*(*) TEXT +C .. Array Arguments .. + COMPLEX*16 A(LDA,*) +C .. Local Scalars .. + INTEGER I, J, J1, J2, JJ, LENTXT, LTEXT, N1 +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC LEN, MIN +C .. Executable Statements .. +C + INFO = 0 +C +C Test the input scalar arguments. +C + IF( M.LT.1 ) THEN + INFO = -1 + ELSE IF( N.LT.1 ) THEN + INFO = -2 + ELSE IF( L.LT.1 .OR. L.GT.3 ) THEN + INFO = -3 + ELSE IF( NOUT.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.M ) THEN + INFO = -6 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01MZ', -INFO ) + RETURN + END IF +C + LENTXT = LEN( TEXT ) +C + DO 20 LTEXT = MIN( 72, LENTXT ), 2, -1 + IF ( TEXT(LTEXT:LTEXT).NE.' ' ) GO TO 40 + 20 CONTINUE +C + 40 CONTINUE + WRITE ( NOUT, FMT=99996 ) TEXT(1:LTEXT), M, N + N1 = ( N-1 )/L + J1 = 1 + J2 = L +C + DO 80 J = 1, N1 + WRITE ( NOUT, FMT=99999 ) ( JJ, JJ=J1, J2 ) +C + DO 60 I = 1, M + WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, J2 ) + 60 CONTINUE +C + WRITE ( NOUT, FMT=99998 ) + J1 = J1 + L + J2 = J2 + L + 80 CONTINUE +C + WRITE ( NOUT, FMT=99999 ) ( J, J=J1, N ) +C + DO 100 I = 1, M + WRITE ( NOUT, FMT=99997 ) I, ( A(I,JJ), JJ=J1, N ) + 100 CONTINUE +C + WRITE ( NOUT, FMT=99998 ) +C + RETURN +C +99999 FORMAT (7X,5(13X,I5,14X) ) +99998 FORMAT (' ' ) +99997 FORMAT (1X,I5,2X,3(D15.7,SP,D15.7,S,'i ') ) +99996 FORMAT (1X,A,' (',I5,'X',I5,')',/ ) +C *** Last line of UD01MZ *** + END diff --git a/mex/sources/libslicot/UD01ND.f b/mex/sources/libslicot/UD01ND.f new file mode 100644 index 000000000..1791f9865 --- /dev/null +++ b/mex/sources/libslicot/UD01ND.f @@ -0,0 +1,203 @@ + SUBROUTINE UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT, + $ INFO ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To print the MP-by-NP coefficient matrices of a matrix polynomial +C dp-1 dp +C P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s + P(dp) * s . +C +C The elements of the matrices are output to 7 significant figures. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C MP (input) INTEGER +C The number of rows of the matrix polynomial P(s). +C MP >= 1. +C +C NP (input) INTEGER +C The number of columns of the matrix polynomial P(s). +C NP >= 1. +C +C DP (input) INTEGER +C The degree of the matrix polynomial P(s). DP >= 0. +C +C L (input) INTEGER +C The number of elements of the coefficient matrices to be +C printed per line. 1 <= L <= 5. +C +C NOUT (input) INTEGER +C The output channel to which the results are sent. +C NOUT >= 0. +C +C P (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1) +C The leading MP-by-NP-by-(DP+1) part of this array must +C contain the coefficients of the matrix polynomial P(s). +C Specifically, P(i,j,k) must contain the coefficient of +C s**(k-1) of the polynomial which is the (i,j)-th element +C of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and +C k = 1,2,...,DP+1. +C +C LDP1 INTEGER +C The leading dimension of array P. LDP1 >= MP. +C +C LDP2 INTEGER +C The second dimension of array P. LDP2 >= NP. +C +C TEXT (input) CHARACTER*72 +C Title caption of the coefficient matrices to be printed. +C TEXT is followed by the degree of the coefficient matrix, +C within brackets. If TEXT = ' ', then the coefficient +C matrices are separated by an empty line. +C +C Error Indicator +C +C INFO INTEGER +C = 0: successful exit; +C < 0: if INFO = -i, the i-th argument had an illegal +C value. +C +C METHOD +C +C For i = 1, 2, ..., DP + 1 the routine first prints the contents of +C TEXT followed by (i-1) as a title, followed by the elements of the +C MP-by-NP coefficient matrix P(i) such that +C (i) if NP < L, then the leading MP-by-NP part is printed; +C (ii) if NP = k*L + p (where k, p > 0), then k MP-by-L blocks of +C consecutive columns of P(i) are printed one after another +C followed by one MP-by-p block containing the last p columns +C of P(i). +C Row numbers are printed on the left of each row and a column +C number on top of each column. +C +C REFERENCES +C +C None. +C +C NUMERICAL ASPECTS +C +C None. +C +C CONTRIBUTOR +C +C Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998. +C Based on routine PRMAPO by A.J. Geurts, Eindhoven University of +C Technology, Holland. +C +C REVISIONS +C +C - +C +C ****************************************************************** +C +C .. Scalar Arguments .. + INTEGER DP, INFO, L, LDP1, LDP2, MP, NP, NOUT + CHARACTER*(*) TEXT +C .. Array Arguments .. + DOUBLE PRECISION P(LDP1,LDP2,*) +C .. Local Scalars .. + INTEGER I, J, J1, J2, JJ, K, LENTXT, LTEXT, N1 +C .. External Subroutines .. + EXTERNAL XERBLA +C .. Intrinsic Functions .. + INTRINSIC LEN, MIN +C +C .. Executable Statements .. +C + INFO = 0 +C +C Check the input scalar arguments. +C + IF( MP.LT.1 ) THEN + INFO = -1 + ELSE IF( NP.LT.1 ) THEN + INFO = -2 + ELSE IF( DP.LT.0 ) THEN + INFO = -3 + ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN + INFO = -4 + ELSE IF( NOUT.LT.0 ) THEN + INFO = -5 + ELSE IF( LDP1.LT.MP ) THEN + INFO = -7 + ELSE IF( LDP2.LT.NP ) THEN + INFO = -8 + END IF +C + IF ( INFO.NE.0 ) THEN +C +C Error return. +C + CALL XERBLA( 'UD01ND', -INFO ) + RETURN + END IF +C + LENTXT = LEN( TEXT ) + LTEXT = MIN( 72, LENTXT ) +C WHILE ( TEXT(LTEXT:LTEXT) = ' ' ) DO + 10 IF ( TEXT(LTEXT:LTEXT).EQ.' ' ) THEN + LTEXT = LTEXT - 1 + GO TO 10 + END IF +C END WHILE 10 +C + DO 50 K = 1, DP + 1 + IF ( LTEXT.EQ.0 ) THEN + WRITE ( NOUT, FMT = 99999 ) + ELSE + WRITE ( NOUT, FMT = 99998 ) TEXT(1:LTEXT), K - 1, MP, NP + END IF + N1 = ( NP - 1 )/L + J1 = 1 + J2 = L +C + DO 30 J = 1, N1 + WRITE ( NOUT, FMT = 99997 ) ( JJ, JJ = J1, J2 ) +C + DO 20 I = 1, MP + WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, J2 ) + 20 CONTINUE +C + J1 = J1 + L + J2 = J2 + L + 30 CONTINUE +C + WRITE ( NOUT, FMT = 99997 ) ( J, J = J1, NP ) +C + DO 40 I = 1, MP + WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, NP ) + 40 CONTINUE +C + 50 CONTINUE +C + WRITE ( NOUT, FMT = 99999 ) +C + RETURN +C +99999 FORMAT (' ') +99998 FORMAT (/, 1X, A, '(', I2, ')', ' (', I2, 'X', I2, ')') +99997 FORMAT (5X, 5(6X, I2, 7X)) +99996 FORMAT (1X, I2, 2X, 5D15.7) +C +C *** Last line of UD01ND *** + END diff --git a/mex/sources/libslicot/UE01MD.f b/mex/sources/libslicot/UE01MD.f new file mode 100644 index 000000000..c460bf9bf --- /dev/null +++ b/mex/sources/libslicot/UE01MD.f @@ -0,0 +1,266 @@ + INTEGER FUNCTION UE01MD( ISPEC, NAME, OPTS, N1, N2, N3 ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C PURPOSE +C +C To provide an extension of the LAPACK routine ILAENV to +C machine-specific parameters for SLICOT routines. +C +C The default values in this version aim to give good performance on +C a wide range of computers. For optimal performance, however, the +C user is advised to modify this routine. Note that an optimized +C BLAS is a crucial prerequisite for any speed gains. For further +C details, see ILAENV. +C +C FUNCTION VALUE +C +C UE01MD INTEGER +C The function value set according to ISPEC. +C +C ARGUMENTS +C +C Input/Output Parameters +C +C ISPEC (input) INTEGER +C Specifies the parameter to be returned as the value of +C UE01MD, as follows: +C = 1: the optimal blocksize; if the returned value is 1, an +C unblocked algorithm will give the best performance; +C = 2: the minimum block size for which the block routine +C should be used; if the usable block size is less than +C this value, an unblocked routine should be used; +C = 3: the crossover point (in a block routine, for N less +C than this value, an unblocked routine should be used) +C = 4: the number of shifts, used in the product eigenvalue +C routine; +C = 8: the crossover point for the multishift QR method for +C product eigenvalue problems. +C +C NAME (input) CHARACTER*(*) +C The name of the calling subroutine, in either upper case +C or lower case. +C +C OPTS (input) CHARACTER*(*) +C The character options to the subroutine NAME, concatenated +C into a single character string. +C +C N1 (input) INTEGER +C N2 (input) INTEGER +C N3 (input) INTEGER +C Problem dimensions for the subroutine NAME; these may not +C all be required. +C +C CONTRIBUTORS +C +C D. Kressner, Technical Univ. Berlin, Germany, and +C P. Benner, Technical Univ. Chemnitz, Germany, December 2003. +C +C REVISIONS +C +C V. Sima, June 2008 (SLICOT version of the HAPACK routine ILAHAP). +C +C ****************************************************************** +C +C .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3 +C +C .. Local Scalars .. + LOGICAL CNAME, SNAME + CHARACTER*1 C1, C3 + CHARACTER*2 C2 + CHARACTER*6 SUBNAM + INTEGER I, IC, IZ, NB, NBMIN, NX +C .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +C .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, MAX +C +C .. Executable Statements .. +C + IF ( ISPEC.EQ.1 .OR. ISPEC.EQ.2 .OR. ISPEC.EQ.3 ) THEN +C +C Convert NAME to upper case if the first character is lower +C case. +C + UE01MD = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1:1 ) ) + IZ = ICHAR( 'Z' ) + IF ( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +C +C ASCII character set. +C + IF ( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 10 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 10 CONTINUE + END IF +C + ELSE IF ( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +C +C EBCDIC character set. +C + IF ( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1:1 ) = CHAR( IC+64 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF ( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) + $ SUBNAM( I:I ) = CHAR( IC+64 ) + 20 CONTINUE + END IF +C + ELSE IF ( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +C +C Prime machines: ASCII+128. +C + IF ( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF ( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 30 CONTINUE + END IF + END IF +C + C1 = SUBNAM( 1:1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF ( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 4:5 ) + C3 = SUBNAM( 6:6 ) +C + IF ( ISPEC.EQ.1 ) THEN +C +C Block size. +C + NB = 1 + IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN + IF ( C3.EQ.'B' ) THEN + NB = ILAENV( 1, 'DGEQRF', ' ', N1, N2, -1, -1 ) / 2 + ELSE IF ( C3.EQ.'T' ) THEN + NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 4 + END IF + ELSE IF ( C2.EQ.'4P' ) THEN + IF ( C3.EQ.'B' ) THEN + NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 + END IF + ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN + IF ( C3.EQ.'D' ) THEN + NB = ILAENV( 1, 'DORGQR', ' ', N1, N2, N3, -1 ) / 2 + ELSE IF ( C3.EQ.'B' ) THEN + NB = ILAENV( 1, 'DORMQR', ' ', N1, N2, N3, -1 ) / 2 + END IF +** ELSE IF ( C2.EQ.'SH' ) THEN +** IF ( C3.EQ.'PVB' ) THEN +** NB = ILAENV( 1, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 +** END IF + END IF + UE01MD = NB + ELSE IF ( ISPEC.EQ.2 ) THEN +C +C Minimum block size. +C + NBMIN = 2 + IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN + IF ( C3.EQ.'B' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', N1, N2, -1, + $ -1 ) / 2 ) + ELSE IF ( C3.EQ.'T' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, + $ -1 ) / 4 ) + END IF + ELSE IF ( C2.EQ.'4P' ) THEN + IF ( C3.EQ.'B' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, + $ -1 ) / 4 ) + END IF + ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN + IF ( C3.EQ.'D' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', N1, N2, N3, + $ -1 ) / 2 ) + ELSE IF ( C3.EQ.'B' ) THEN + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', ' ', N1, N2, N3, + $ -1 ) / 2 ) + END IF +** ELSE IF ( C2.EQ.'SH' ) THEN +** IF ( C3.EQ.'PVB' ) THEN +** NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N1, N2, N1, +** $ -1 ) / 4 ) +** END IF + END IF + UE01MD = NBMIN + ELSE IF ( ISPEC.EQ.3 ) THEN +C +C Crossover point. +C + NX = 0 + IF ( C2.EQ.'4S' .OR. C2.EQ.'4T' ) THEN + IF ( C3.EQ.'B' ) THEN + NX = ILAENV( 3, 'DGEQRF', ' ', N1, N2, -1, -1 ) + ELSE IF ( C3.EQ.'T' ) THEN + NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 + END IF + ELSE IF ( C2.EQ.'4P' ) THEN + IF ( C3.EQ.'B' ) THEN + NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 + END IF + ELSE IF ( C2.EQ.'4W' .OR. C2.EQ.'4Q' ) THEN + IF ( C3.EQ.'D' ) THEN + NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) + ELSE IF ( C3.EQ.'B' ) THEN + NX = ILAENV( 3, 'DORGQR', ' ', N1, N2, N3, -1 ) + END IF +** ELSE IF ( C2.EQ.'SH' ) THEN +** IF ( C3.EQ.'PVB' ) THEN +** NX = ILAENV( 3, 'DGEHRD', ' ', N1, N2, N1, -1 ) / 2 +** END IF + END IF + UE01MD = NX + END IF + ELSE IF ( ISPEC.EQ.4 ) THEN +C +C Number of shifts (used by MB03XP). +C + UE01MD = ILAENV( 4, 'DHSEQR', OPTS, N1, N2, N3, -1 ) + ELSE IF ( ISPEC.EQ.8 ) THEN +C +C Crossover point for multishift (used by MB03XP). +C + UE01MD = ILAENV( 8, 'DHSEQR', OPTS, N1, N2, N3, -1 ) + ELSE +C +C Invalid value for ISPEC. +C + UE01MD = -1 + END IF + RETURN +C *** Last line of UE01MD *** + END diff --git a/mex/sources/libslicot/dcabs1.f b/mex/sources/libslicot/dcabs1.f new file mode 100644 index 000000000..c4acbeb5a --- /dev/null +++ b/mex/sources/libslicot/dcabs1.f @@ -0,0 +1,16 @@ + DOUBLE PRECISION FUNCTION DCABS1(Z) +* .. Scalar Arguments .. + DOUBLE COMPLEX Z +* .. +* .. +* Purpose +* ======= +* +* DCABS1 computes absolute value of a double complex number +* +* .. Intrinsic Functions .. + INTRINSIC ABS,DBLE,DIMAG +* + DCABS1 = ABS(DBLE(Z)) + ABS(DIMAG(Z)) + RETURN + END diff --git a/mex/sources/libslicot/delctg.f b/mex/sources/libslicot/delctg.f new file mode 100644 index 000000000..b6b44b7c8 --- /dev/null +++ b/mex/sources/libslicot/delctg.f @@ -0,0 +1,27 @@ + LOGICAL FUNCTION DELCTG( PAR1, PAR2, PAR3 ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Void logical function for DGGES. +C + DOUBLE PRECISION PAR1, PAR2, PAR3 +C + DELCTG = .TRUE. + RETURN + END diff --git a/mex/sources/libslicot/dhgeqz.f b/mex/sources/libslicot/dhgeqz.f new file mode 100644 index 000000000..2269451e1 --- /dev/null +++ b/mex/sources/libslicot/dhgeqz.f @@ -0,0 +1,1249 @@ + SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, + $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, + $ LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPQ, COMPZ, JOB + INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ), + $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ), + $ WORK( * ), Z( LDZ, * ) +* .. +* +* Purpose +* ======= +* +* DHGEQZ computes the eigenvalues of a real matrix pair (H,T), +* where H is an upper Hessenberg matrix and T is upper triangular, +* using the double-shift QZ method. +* Matrix pairs of this type are produced by the reduction to +* generalized upper Hessenberg form of a real matrix pair (A,B): +* +* A = Q1*H*Z1**T, B = Q1*T*Z1**T, +* +* as computed by DGGHRD. +* +* If JOB='S', then the Hessenberg-triangular pair (H,T) is +* also reduced to generalized Schur form, +* +* H = Q*S*Z**T, T = Q*P*Z**T, +* +* where Q and Z are orthogonal matrices, P is an upper triangular +* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2 +* diagonal blocks. +* +* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair +* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of +* eigenvalues. +* +* Additionally, the 2-by-2 upper triangular diagonal blocks of P +* corresponding to 2-by-2 blocks of S are reduced to positive diagonal +* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0, +* P(j,j) > 0, and P(j+1,j+1) > 0. +* +* Optionally, the orthogonal matrix Q from the generalized Schur +* factorization may be postmultiplied into an input matrix Q1, and the +* orthogonal matrix Z may be postmultiplied into an input matrix Z1. +* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced +* the matrix pair (A,B) to generalized upper Hessenberg form, then the +* output matrices Q1*Q and Z1*Z are the orthogonal factors from the +* generalized Schur factorization of (A,B): +* +* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T. +* +* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently, +* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is +* complex and beta real. +* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the +* generalized nonsymmetric eigenvalue problem (GNEP) +* A*x = lambda*B*x +* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the +* alternate form of the GNEP +* mu*A*y = B*y. +* Real eigenvalues can be read directly from the generalized Schur +* form: +* alpha = S(i,i), beta = P(i,i). +* +* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix +* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), +* pp. 241--256. +* +* Arguments +* ========= +* +* JOB (input) CHARACTER*1 +* = 'E': Compute eigenvalues only; +* = 'S': Compute eigenvalues and the Schur form. +* +* COMPQ (input) CHARACTER*1 +* = 'N': Left Schur vectors (Q) are not computed; +* = 'I': Q is initialized to the unit matrix and the matrix Q +* of left Schur vectors of (H,T) is returned; +* = 'V': Q must contain an orthogonal matrix Q1 on entry and +* the product Q1*Q is returned. +* +* COMPZ (input) CHARACTER*1 +* = 'N': Right Schur vectors (Z) are not computed; +* = 'I': Z is initialized to the unit matrix and the matrix Z +* of right Schur vectors of (H,T) is returned; +* = 'V': Z must contain an orthogonal matrix Z1 on entry and +* the product Z1*Z is returned. +* +* N (input) INTEGER +* The order of the matrices H, T, Q, and Z. N >= 0. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* ILO and IHI mark the rows and columns of H which are in +* Hessenberg form. It is assumed that A is already upper +* triangular in rows and columns 1:ILO-1 and IHI+1:N. +* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. +* +* H (input/output) DOUBLE PRECISION array, dimension (LDH, N) +* On entry, the N-by-N upper Hessenberg matrix H. +* On exit, if JOB = 'S', H contains the upper quasi-triangular +* matrix S from the generalized Schur factorization; +* 2-by-2 diagonal blocks (corresponding to complex conjugate +* pairs of eigenvalues) are returned in standard form, with +* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. +* If JOB = 'E', the diagonal blocks of H match those of S, but +* the rest of H is unspecified. +* +* LDH (input) INTEGER +* The leading dimension of the array H. LDH >= max( 1, N ). +* +* T (input/output) DOUBLE PRECISION array, dimension (LDT, N) +* On entry, the N-by-N upper triangular matrix T. +* On exit, if JOB = 'S', T contains the upper triangular +* matrix P from the generalized Schur factorization; +* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S +* are reduced to positive diagonal form, i.e., if H(j+1,j) is +* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and +* T(j+1,j+1) > 0. +* If JOB = 'E', the diagonal blocks of T match those of P, but +* the rest of T is unspecified. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= max( 1, N ). +* +* ALPHAR (output) DOUBLE PRECISION array, dimension (N) +* The real parts of each scalar alpha defining an eigenvalue +* of GNEP. +* +* ALPHAI (output) DOUBLE PRECISION array, dimension (N) +* The imaginary parts of each scalar alpha defining an +* eigenvalue of GNEP. +* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if +* positive, then the j-th and (j+1)-st eigenvalues are a +* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j). +* +* BETA (output) DOUBLE PRECISION array, dimension (N) +* The scalars beta that define the eigenvalues of GNEP. +* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and +* beta = BETA(j) represent the j-th eigenvalue of the matrix +* pair (A,B), in one of the forms lambda = alpha/beta or +* mu = beta/alpha. Since either lambda or mu may overflow, +* they should not, in general, be computed. +* +* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N) +* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur +* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix +* of left Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. +* +* LDQ (input) INTEGER +* The leading dimension of the array Q. LDQ >= 1. +* If COMPQ='V' or 'I', then LDQ >= N. +* +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) +* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in +* the reduction of (A,B) to generalized Hessenberg form. +* On exit, if COMPZ = 'I', the orthogonal matrix of +* right Schur vectors of (H,T), and if COMPZ = 'V', the +* orthogonal matrix of right Schur vectors of (A,B). +* Not referenced if COMPZ = 'N'. +* +* LDZ (input) INTEGER +* The leading dimension of the array Z. LDZ >= 1. +* If COMPZ='V' or 'I', then LDZ >= N. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* = 1,...,N: the QZ iteration did not converge. (H,T) is not +* in Schur form, but ALPHAR(i), ALPHAI(i), and +* BETA(i), i=INFO+1,...,N should be correct. +* = N+1,...,2*N: the shift calculation failed. (H,T) is not +* in Schur form, but ALPHAR(i), ALPHAI(i), and +* BETA(i), i=INFO-N+1,...,N should be correct. +* +* Further Details +* =============== +* +* Iteration counters: +* +* JITER -- counts iterations. +* IITER -- counts iterations run since ILAST was last +* changed. This is therefore reset only when a 1-by-1 or +* 2-by-2 block deflates off the bottom. +* +* ===================================================================== +* +* .. Parameters .. +* $ SAFETY = 1.0E+0 ) + DOUBLE PRECISION HALF, ZERO, ONE, SAFETY + PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0, + $ SAFETY = 1.0D+2 ) +* .. +* .. Local Scalars .. + LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ, + $ LQUERY + INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST, + $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER, + $ JR, MAXIT + DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11, + $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L, + $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I, + $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE, + $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, + $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, + $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, + $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, + $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, + $ WR2 +* .. +* .. Local Arrays .. + DOUBLE PRECISION V( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3 + EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3 +* .. +* .. External Subroutines .. + EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* Decode JOB, COMPQ, COMPZ +* + IF( LSAME( JOB, 'E' ) ) THEN + ILSCHR = .FALSE. + ISCHUR = 1 + ELSE IF( LSAME( JOB, 'S' ) ) THEN + ILSCHR = .TRUE. + ISCHUR = 2 + ELSE + ISCHUR = 0 + END IF +* + IF( LSAME( COMPQ, 'N' ) ) THEN + ILQ = .FALSE. + ICOMPQ = 1 + ELSE IF( LSAME( COMPQ, 'V' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 2 + ELSE IF( LSAME( COMPQ, 'I' ) ) THEN + ILQ = .TRUE. + ICOMPQ = 3 + ELSE + ICOMPQ = 0 + END IF +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ILZ = .FALSE. + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 2 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ILZ = .TRUE. + ICOMPZ = 3 + ELSE + ICOMPZ = 0 + END IF +* +* Check Argument Values +* + INFO = 0 + WORK( 1 ) = MAX( 1, N ) + LQUERY = ( LWORK.EQ.-1 ) + IF( ISCHUR.EQ.0 ) THEN + INFO = -1 + ELSE IF( ICOMPQ.EQ.0 ) THEN + INFO = -2 + ELSE IF( ICOMPZ.EQ.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( ILO.LT.1 ) THEN + INFO = -5 + ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN + INFO = -6 + ELSE IF( LDH.LT.N ) THEN + INFO = -8 + ELSE IF( LDT.LT.N ) THEN + INFO = -10 + ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN + INFO = -15 + ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN + INFO = -17 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -19 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DHGEQZ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = DBLE( 1 ) + RETURN + END IF +* +* Initialize Q and Z +* + IF( ICOMPQ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ ) + IF( ICOMPZ.EQ.3 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* +* Machine Constants +* + IN = IHI + 1 - ILO + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + ULP = DLAMCH( 'E' )*DLAMCH( 'B' ) + ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK ) + BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK ) + ATOL = MAX( SAFMIN, ULP*ANORM ) + BTOL = MAX( SAFMIN, ULP*BNORM ) + ASCALE = ONE / MAX( SAFMIN, ANORM ) + BSCALE = ONE / MAX( SAFMIN, BNORM ) +* +* Set Eigenvalues IHI+1:N +* + DO 30 J = IHI + 1, N + IF( T( J, J ).LT.ZERO ) THEN + IF( ILSCHR ) THEN + DO 10 JR = 1, J + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) + 10 CONTINUE + ELSE + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) + END IF + IF( ILZ ) THEN + DO 20 JR = 1, N + Z( JR, J ) = -Z( JR, J ) + 20 CONTINUE + END IF + END IF + ALPHAR( J ) = H( J, J ) + ALPHAI( J ) = ZERO + BETA( J ) = T( J, J ) + 30 CONTINUE +* +* If IHI < ILO, skip QZ steps +* + IF( IHI.LT.ILO ) + $ GO TO 380 +* +* MAIN QZ ITERATION LOOP +* +* Initialize dynamic indices +* +* Eigenvalues ILAST+1:N have been found. +* Column operations modify rows IFRSTM:whatever. +* Row operations modify columns whatever:ILASTM. +* +* If only eigenvalues are being computed, then +* IFRSTM is the row of the last splitting row above row ILAST; +* this is always at least ILO. +* IITER counts iterations since the last eigenvalue was found, +* to tell when to use an extraordinary shift. +* MAXIT is the maximum number of QZ sweeps allowed. +* + ILAST = IHI + IF( ILSCHR ) THEN + IFRSTM = 1 + ILASTM = N + ELSE + IFRSTM = ILO + ILASTM = IHI + END IF + IITER = 0 + ESHIFT = ZERO + MAXIT = 30*( IHI-ILO+1 ) +* + DO 360 JITER = 1, MAXIT +* +* Split the matrix if possible. +* +* Two tests: +* 1: H(j,j-1)=0 or j=ILO +* 2: T(j,j)=0 +* + IF( ILAST.EQ.ILO ) THEN +* +* Special case: j=ILAST +* + GO TO 80 + ELSE + IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN + H( ILAST, ILAST-1 ) = ZERO + GO TO 80 + END IF + END IF +* + IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN + T( ILAST, ILAST ) = ZERO + GO TO 70 + END IF +* +* General case: j unfl ) +* __ +* (sA - wB) ( CZ -SZ ) +* ( SZ CZ ) +* + C11R = S1*A11 - WR*B11 + C11I = -WI*B11 + C12 = S1*A12 + C21 = S1*A21 + C22R = S1*A22 - WR*B22 + C22I = -WI*B22 +* + IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+ + $ ABS( C22R )+ABS( C22I ) ) THEN + T1 = DLAPY3( C12, C11R, C11I ) + CZ = C12 / T1 + SZR = -C11R / T1 + SZI = -C11I / T1 + ELSE + CZ = DLAPY2( C22R, C22I ) + IF( CZ.LE.SAFMIN ) THEN + CZ = ZERO + SZR = ONE + SZI = ZERO + ELSE + TEMPR = C22R / CZ + TEMPI = C22I / CZ + T1 = DLAPY2( CZ, C21 ) + CZ = CZ / T1 + SZR = -C21*TEMPR / T1 + SZI = C21*TEMPI / T1 + END IF + END IF +* +* Compute Givens rotation on left +* +* ( CQ SQ ) +* ( __ ) A or B +* ( -SQ CQ ) +* + AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 ) + BN = ABS( B11 ) + ABS( B22 ) + WABS = ABS( WR ) + ABS( WI ) + IF( S1*AN.GT.WABS*BN ) THEN + CQ = CZ*B11 + SQR = SZR*B22 + SQI = -SZI*B22 + ELSE + A1R = CZ*A11 + SZR*A12 + A1I = SZI*A12 + A2R = CZ*A21 + SZR*A22 + A2I = SZI*A22 + CQ = DLAPY2( A1R, A1I ) + IF( CQ.LE.SAFMIN ) THEN + CQ = ZERO + SQR = ONE + SQI = ZERO + ELSE + TEMPR = A1R / CQ + TEMPI = A1I / CQ + SQR = TEMPR*A2R + TEMPI*A2I + SQI = TEMPI*A2R - TEMPR*A2I + END IF + END IF + T1 = DLAPY3( CQ, SQR, SQI ) + CQ = CQ / T1 + SQR = SQR / T1 + SQI = SQI / T1 +* +* Compute diagonal elements of QBZ +* + TEMPR = SQR*SZR - SQI*SZI + TEMPI = SQR*SZI + SQI*SZR + B1R = CQ*CZ*B11 + TEMPR*B22 + B1I = TEMPI*B22 + B1A = DLAPY2( B1R, B1I ) + B2R = CQ*CZ*B22 + TEMPR*B11 + B2I = -TEMPI*B11 + B2A = DLAPY2( B2R, B2I ) +* +* Normalize so beta > 0, and Im( alpha1 ) > 0 +* + BETA( ILAST-1 ) = B1A + BETA( ILAST ) = B2A + ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV + ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV + ALPHAR( ILAST ) = ( WR*B2A )*S1INV + ALPHAI( ILAST ) = -( WI*B2A )*S1INV +* +* Step 3: Go to next block -- exit if finished. +* + ILAST = IFIRST - 1 + IF( ILAST.LT.ILO ) + $ GO TO 380 +* +* Reset counters +* + IITER = 0 + ESHIFT = ZERO + IF( .NOT.ILSCHR ) THEN + ILASTM = ILAST + IF( IFRSTM.GT.ILAST ) + $ IFRSTM = ILO + END IF + GO TO 350 + ELSE +* +* Usual case: 3x3 or larger block, using Francis implicit +* double-shift +* +* 2 +* Eigenvalue equation is w - c w + d = 0, +* +* -1 2 -1 +* so compute 1st column of (A B ) - c A B + d +* using the formula in QZIT (from EISPACK) +* +* We assume that the block is at least 3x3 +* + AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) / + $ ( BSCALE*T( ILAST-1, ILAST-1 ) ) + AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + AD22 = ( ASCALE*H( ILAST, ILAST ) ) / + $ ( BSCALE*T( ILAST, ILAST ) ) + U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST ) + AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) / + $ ( BSCALE*T( IFIRST, IFIRST ) ) + AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) / + $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) ) + U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 ) +* + V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 + + $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L + V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )- + $ ( AD22-AD11L )+AD21*U12 )*AD21L + V( 3 ) = AD32L*AD21L +* + ISTART = IFIRST +* + CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU ) + V( 1 ) = ONE +* +* Sweep +* + DO 290 J = ISTART, ILAST - 2 +* +* All but last elements: use 3x3 Householder transforms. +* +* Zero (j-1)st column of A +* + IF( J.GT.ISTART ) THEN + V( 1 ) = H( J, J-1 ) + V( 2 ) = H( J+1, J-1 ) + V( 3 ) = H( J+2, J-1 ) +* + CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU ) + V( 1 ) = ONE + H( J+1, J-1 ) = ZERO + H( J+2, J-1 ) = ZERO + END IF +* + DO 230 JC = J, ILASTM + TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) ) + H( J, JC ) = H( J, JC ) - TEMP + H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) + H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) + TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) ) + T( J, JC ) = T( J, JC ) - TEMP2 + T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) + T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) + 230 CONTINUE + IF( ILQ ) THEN + DO 240 JR = 1, N + TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* + $ Q( JR, J+2 ) ) + Q( JR, J ) = Q( JR, J ) - TEMP + Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) + Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) + 240 CONTINUE + END IF +* +* Zero j-th column of B (see DLAGBC for details) +* +* Swap rows to pivot +* + ILPIVT = .FALSE. + TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) ) + TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) ) + IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN + SCALE = ZERO + U1 = ONE + U2 = ZERO + GO TO 250 + ELSE IF( TEMP.GE.TEMP2 ) THEN + W11 = T( J+1, J+1 ) + W21 = T( J+2, J+1 ) + W12 = T( J+1, J+2 ) + W22 = T( J+2, J+2 ) + U1 = T( J+1, J ) + U2 = T( J+2, J ) + ELSE + W21 = T( J+1, J+1 ) + W11 = T( J+2, J+1 ) + W22 = T( J+1, J+2 ) + W12 = T( J+2, J+2 ) + U2 = T( J+1, J ) + U1 = T( J+2, J ) + END IF +* +* Swap columns if nec. +* + IF( ABS( W12 ).GT.ABS( W11 ) ) THEN + ILPIVT = .TRUE. + TEMP = W12 + TEMP2 = W22 + W12 = W11 + W22 = W21 + W11 = TEMP + W21 = TEMP2 + END IF +* +* LU-factor +* + TEMP = W21 / W11 + U2 = U2 - TEMP*U1 + W22 = W22 - TEMP*W12 + W21 = ZERO +* +* Compute SCALE +* + SCALE = ONE + IF( ABS( W22 ).LT.SAFMIN ) THEN + SCALE = ZERO + U2 = ONE + U1 = -W12 / W11 + GO TO 250 + END IF + IF( ABS( W22 ).LT.ABS( U2 ) ) + $ SCALE = ABS( W22 / U2 ) + IF( ABS( W11 ).LT.ABS( U1 ) ) + $ SCALE = MIN( SCALE, ABS( W11 / U1 ) ) +* +* Solve +* + U2 = ( SCALE*U2 ) / W22 + U1 = ( SCALE*U1-W12*U2 ) / W11 +* + 250 CONTINUE + IF( ILPIVT ) THEN + TEMP = U2 + U2 = U1 + U1 = TEMP + END IF +* +* Compute Householder Vector +* + T1 = SQRT( SCALE**2+U1**2+U2**2 ) + TAU = ONE + SCALE / T1 + VS = -ONE / ( SCALE+T1 ) + V( 1 ) = ONE + V( 2 ) = VS*U1 + V( 3 ) = VS*U2 +* +* Apply transformations from the right. +* + DO 260 JR = IFRSTM, MIN( J+3, ILAST ) + TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) ) + H( JR, J ) = H( JR, J ) - TEMP + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) + 260 CONTINUE + DO 270 JR = IFRSTM, J + 2 + TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) ) + T( JR, J ) = T( JR, J ) - TEMP + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) + 270 CONTINUE + IF( ILZ ) THEN + DO 280 JR = 1, N + TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* + $ Z( JR, J+2 ) ) + Z( JR, J ) = Z( JR, J ) - TEMP + Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) + Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) + 280 CONTINUE + END IF + T( J+1, J ) = ZERO + T( J+2, J ) = ZERO + 290 CONTINUE +* +* Last elements: Use Givens rotations +* +* Rotations from the left +* + J = ILAST - 1 + TEMP = H( J, J-1 ) + CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) ) + H( J+1, J-1 ) = ZERO +* + DO 300 JC = J, ILASTM + TEMP = C*H( J, JC ) + S*H( J+1, JC ) + H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC ) + H( J, JC ) = TEMP + TEMP2 = C*T( J, JC ) + S*T( J+1, JC ) + T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC ) + T( J, JC ) = TEMP2 + 300 CONTINUE + IF( ILQ ) THEN + DO 310 JR = 1, N + TEMP = C*Q( JR, J ) + S*Q( JR, J+1 ) + Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 ) + Q( JR, J ) = TEMP + 310 CONTINUE + END IF +* +* Rotations from the right. +* + TEMP = T( J+1, J+1 ) + CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) ) + T( J+1, J ) = ZERO +* + DO 320 JR = IFRSTM, ILAST + TEMP = C*H( JR, J+1 ) + S*H( JR, J ) + H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J ) + H( JR, J+1 ) = TEMP + 320 CONTINUE + DO 330 JR = IFRSTM, ILAST - 1 + TEMP = C*T( JR, J+1 ) + S*T( JR, J ) + T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J ) + T( JR, J+1 ) = TEMP + 330 CONTINUE + IF( ILZ ) THEN + DO 340 JR = 1, N + TEMP = C*Z( JR, J+1 ) + S*Z( JR, J ) + Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J ) + Z( JR, J+1 ) = TEMP + 340 CONTINUE + END IF +* +* End of Double-Shift code +* + END IF +* + GO TO 350 +* +* End of iteration loop +* + 350 CONTINUE + 360 CONTINUE +* +* Drop-through = non-convergence +* + INFO = ILAST + GO TO 420 +* +* Successful completion of all QZ steps +* + 380 CONTINUE +* +* Set Eigenvalues 1:ILO-1 +* + DO 410 J = 1, ILO - 1 + IF( T( J, J ).LT.ZERO ) THEN + IF( ILSCHR ) THEN + DO 390 JR = 1, J + H( JR, J ) = -H( JR, J ) + T( JR, J ) = -T( JR, J ) + 390 CONTINUE + ELSE + H( J, J ) = -H( J, J ) + T( J, J ) = -T( J, J ) + END IF + IF( ILZ ) THEN + DO 400 JR = 1, N + Z( JR, J ) = -Z( JR, J ) + 400 CONTINUE + END IF + END IF + ALPHAR( J ) = H( J, J ) + ALPHAI( J ) = ZERO + BETA( J ) = T( J, J ) + 410 CONTINUE +* +* Normal Termination +* + INFO = 0 +* +* Exit (other than argument error) -- return optimal workspace size +* + 420 CONTINUE + WORK( 1 ) = DBLE( N ) + RETURN +* +* End of DHGEQZ +* + END diff --git a/mex/sources/libslicot/dtgsy2.f b/mex/sources/libslicot/dtgsy2.f new file mode 100644 index 000000000..3486ec482 --- /dev/null +++ b/mex/sources/libslicot/dtgsy2.f @@ -0,0 +1,956 @@ + SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, + $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, + $ IWORK, PQ, INFO ) +* +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* January 2007. V. Sima, February 2009: added IWORK in former 640. +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, + $ PQ + DOUBLE PRECISION RDSCAL, RDSUM, SCALE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), + $ D( LDD, * ), E( LDE, * ), F( LDF, * ) +* .. +* +* Purpose +* ======= +* +* DTGSY2 solves the generalized Sylvester equation: +* +* A * R - L * B = scale * C (1) +* D * R - L * E = scale * F, +* +* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, +* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, +* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) +* must be in generalized Schur canonical form, i.e. A, B are upper +* quasi triangular and D, E are upper triangular. The solution (R, L) +* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor +* chosen to avoid overflow. +* +* In matrix notation solving equation (1) corresponds to solve +* Z*x = scale*b, where Z is defined as +* +* Z = [ kron(In, A) -kron(B', Im) ] (2) +* [ kron(In, D) -kron(E', Im) ], +* +* Ik is the identity matrix of size k and X' is the transpose of X. +* kron(X, Y) is the Kronecker product between the matrices X and Y. +* In the process of solving (1), we solve a number of such systems +* where Dim(In), Dim(In) = 1 or 2. +* +* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, +* which is equivalent to solve for R and L in +* +* A' * R + D' * L = scale * C (3) +* R * B' + L * E' = scale * -F +* +* This case is used to compute an estimate of Dif[(A, D), (B, E)] = +* sigma_min(Z) using reverse communicaton with DLACON. +* +* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL +* of an upper bound on the separation between to matrix pairs. Then +* the input (A, D), (B, E) are sub-pencils of the matrix pair in +* DTGSYL. See DTGSYL for details. +* +* Arguments +* ========= +* +* TRANS (input) CHARACTER*1 +* = 'N', solve the generalized Sylvester equation (1). +* = 'T': solve the 'transposed' system (3). +* +* IJOB (input) INTEGER +* Specifies what kind of functionality to be performed. +* = 0: solve (1) only. +* = 1: A contribution from this subsystem to a Frobenius +* norm-based estimate of the separation between two matrix +* pairs is computed. (look ahead strategy is used). +* = 2: A contribution from this subsystem to a Frobenius +* norm-based estimate of the separation between two matrix +* pairs is computed. (DGECON on sub-systems is used.) +* Not referenced if TRANS = 'T'. +* +* M (input) INTEGER +* On entry, M specifies the order of A and D, and the row +* dimension of C, F, R and L. +* +* N (input) INTEGER +* On entry, N specifies the order of B and E, and the column +* dimension of C, F, R and L. +* +* A (input) DOUBLE PRECISION array, dimension (LDA, M) +* On entry, A contains an upper quasi triangular matrix. +* +* LDA (input) INTEGER +* The leading dimension of the matrix A. LDA >= max(1, M). +* +* B (input) DOUBLE PRECISION array, dimension (LDB, N) +* On entry, B contains an upper quasi triangular matrix. +* +* LDB (input) INTEGER +* The leading dimension of the matrix B. LDB >= max(1, N). +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC, N) +* On entry, C contains the right-hand-side of the first matrix +* equation in (1). +* On exit, if IJOB = 0, C has been overwritten by the +* solution R. +* +* LDC (input) INTEGER +* The leading dimension of the matrix C. LDC >= max(1, M). +* +* D (input) DOUBLE PRECISION array, dimension (LDD, M) +* On entry, D contains an upper triangular matrix. +* +* LDD (input) INTEGER +* The leading dimension of the matrix D. LDD >= max(1, M). +* +* E (input) DOUBLE PRECISION array, dimension (LDE, N) +* On entry, E contains an upper triangular matrix. +* +* LDE (input) INTEGER +* The leading dimension of the matrix E. LDE >= max(1, N). +* +* F (input/output) DOUBLE PRECISION array, dimension (LDF, N) +* On entry, F contains the right-hand-side of the second matrix +* equation in (1). +* On exit, if IJOB = 0, F has been overwritten by the +* solution L. +* +* LDF (input) INTEGER +* The leading dimension of the matrix F. LDF >= max(1, M). +* +* SCALE (output) DOUBLE PRECISION +* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions +* R and L (C and F on entry) will hold the solutions to a +* slightly perturbed system but the input matrices A, B, D and +* E have not been changed. If SCALE = 0, R and L will hold the +* solutions to the homogeneous system with C = F = 0. Normally, +* SCALE = 1. +* +* RDSUM (input/output) DOUBLE PRECISION +* On entry, the sum of squares of computed contributions to +* the Dif-estimate under computation by DTGSYL, where the +* scaling factor RDSCAL (see below) has been factored out. +* On exit, the corresponding sum of squares updated with the +* contributions from the current sub-system. +* If TRANS = 'T' RDSUM is not touched. +* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL. +* +* RDSCAL (input/output) DOUBLE PRECISION +* On entry, scaling factor used to prevent overflow in RDSUM. +* On exit, RDSCAL is updated w.r.t. the current contributions +* in RDSUM. +* If TRANS = 'T', RDSCAL is not touched. +* NOTE: RDSCAL only makes sense when DTGSY2 is called by +* DTGSYL. +* +* IWORK (workspace) INTEGER array, dimension (M+N+2) +* +* PQ (output) INTEGER +* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and +* 8-by-8) solved by this routine. +* +* INFO (output) INTEGER +* On exit, if INFO is set to +* =0: Successful exit +* <0: If INFO = -i, the i-th argument had an illegal value. +* >0: The matrix pairs (A, D) and (B, E) have common or very +* close eigenvalues. +* +* Further Details +* =============== +* +* Based on contributions by +* Bo Kagstrom and Peter Poromaa, Department of Computing Science, +* Umea University, S-901 87 Umea, Sweden. +* +* ===================================================================== +* Replaced various illegal calls to DCOPY by calls to DLASET. +* Sven Hammarling, 27/5/02. +* +* .. Parameters .. + INTEGER LDZ + PARAMETER ( LDZ = 8 ) + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN + INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1, + $ K, MB, NB, P, Q, ZDIM + DOUBLE PRECISION ALPHA, SCALOC +* .. +* .. Local Arrays .. + INTEGER IPIV( LDZ ), JPIV( LDZ ) + DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2, + $ DGETC2, DLASET, DLATDF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Decode and test input parameters +* + INFO = 0 + IERR = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -1 + ELSE IF( NOTRAN ) THEN + IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN + INFO = -2 + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( M.LE.0 ) THEN + INFO = -3 + ELSE IF( N.LE.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LDD.LT.MAX( 1, M ) ) THEN + INFO = -12 + ELSE IF( LDE.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDF.LT.MAX( 1, M ) ) THEN + INFO = -16 + END IF + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTGSY2', -INFO ) + RETURN + END IF +* +* Determine block structure of A +* + PQ = 0 + P = 0 + I = 1 + 10 CONTINUE + IF( I.GT.M ) + $ GO TO 20 + P = P + 1 + IWORK( P ) = I + IF( I.EQ.M ) + $ GO TO 20 + IF( A( I+1, I ).NE.ZERO ) THEN + I = I + 2 + ELSE + I = I + 1 + END IF + GO TO 10 + 20 CONTINUE + IWORK( P+1 ) = M + 1 +* +* Determine block structure of B +* + Q = P + 1 + J = 1 + 30 CONTINUE + IF( J.GT.N ) + $ GO TO 40 + Q = Q + 1 + IWORK( Q ) = J + IF( J.EQ.N ) + $ GO TO 40 + IF( B( J+1, J ).NE.ZERO ) THEN + J = J + 2 + ELSE + J = J + 1 + END IF + GO TO 30 + 40 CONTINUE + IWORK( Q+1 ) = N + 1 + PQ = P*( Q-P-1 ) +* + IF( NOTRAN ) THEN +* +* Solve (I, J) - subsystem +* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) +* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) +* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q +* + SCALE = ONE + SCALOC = ONE + DO 120 J = P + 2, Q + JS = IWORK( J ) + JSP1 = JS + 1 + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + DO 110 I = P, 1, -1 +* + IS = IWORK( I ) + ISP1 = IS + 1 + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + ZDIM = MB*NB*2 +* + IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 2-by-2 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = D( IS, IS ) + Z( 1, 2 ) = -B( JS, JS ) + Z( 2, 2 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = F( IS, JS ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 50 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 50 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + F( IS, JS ) = RHS( 2 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + ALPHA = -RHS( 1 ) + CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ), + $ 1 ) + CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ), + $ 1 ) + END IF + IF( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + END IF +* + ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build a 4-by-4 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = ZERO + Z( 3, 1 ) = D( IS, IS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = ZERO + Z( 2, 2 ) = A( IS, IS ) + Z( 3, 2 ) = ZERO + Z( 4, 2 ) = D( IS, IS ) +* + Z( 1, 3 ) = -B( JS, JS ) + Z( 2, 3 ) = -B( JS, JSP1 ) + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = -E( JS, JSP1 ) +* + Z( 1, 4 ) = -B( JSP1, JS ) + Z( 2, 4 ) = -B( JSP1, JSP1 ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( IS, JSP1 ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( IS, JSP1 ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 60 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 60 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( IS, JSP1 ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( IS, JSP1 ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ), + $ 1, C( 1, JS ), LDC ) + CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ), + $ 1, F( 1, JS ), LDF ) + END IF + IF( J.LT.Q ) THEN + CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB, + $ C( IS, JE+1 ), LDC ) + CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE, + $ F( IS, JE+1 ), LDF ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 4-by-4 system Z * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( ISP1, IS ) + Z( 3, 1 ) = D( IS, IS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = A( IS, ISP1 ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 3, 2 ) = D( IS, ISP1 ) + Z( 4, 2 ) = D( ISP1, ISP1 ) +* + Z( 1, 3 ) = -B( JS, JS ) + Z( 2, 3 ) = ZERO + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = -B( JS, JS ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( ISP1, JS ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( ISP1, JS ) +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 70 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 70 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( ISP1, JS ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( ISP1, JS ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA, + $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 ) + CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD, + $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 ) + END IF + IF( J.LT.Q ) THEN + CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, + $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC ) + CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1, + $ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build an 8-by-8 system Z * x = RHS +* + CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( ISP1, IS ) + Z( 5, 1 ) = D( IS, IS ) +* + Z( 1, 2 ) = A( IS, ISP1 ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 5, 2 ) = D( IS, ISP1 ) + Z( 6, 2 ) = D( ISP1, ISP1 ) +* + Z( 3, 3 ) = A( IS, IS ) + Z( 4, 3 ) = A( ISP1, IS ) + Z( 7, 3 ) = D( IS, IS ) +* + Z( 3, 4 ) = A( IS, ISP1 ) + Z( 4, 4 ) = A( ISP1, ISP1 ) + Z( 7, 4 ) = D( IS, ISP1 ) + Z( 8, 4 ) = D( ISP1, ISP1 ) +* + Z( 1, 5 ) = -B( JS, JS ) + Z( 3, 5 ) = -B( JS, JSP1 ) + Z( 5, 5 ) = -E( JS, JS ) + Z( 7, 5 ) = -E( JS, JSP1 ) +* + Z( 2, 6 ) = -B( JS, JS ) + Z( 4, 6 ) = -B( JS, JSP1 ) + Z( 6, 6 ) = -E( JS, JS ) + Z( 8, 6 ) = -E( JS, JSP1 ) +* + Z( 1, 7 ) = -B( JSP1, JS ) + Z( 3, 7 ) = -B( JSP1, JSP1 ) + Z( 7, 7 ) = -E( JSP1, JSP1 ) +* + Z( 2, 8 ) = -B( JSP1, JS ) + Z( 4, 8 ) = -B( JSP1, JSP1 ) + Z( 8, 8 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + K = 1 + II = MB*NB + 1 + DO 80 JJ = 0, NB - 1 + CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) + CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) + K = K + MB + II = II + MB + 80 CONTINUE +* +* Solve Z * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + IF( IJOB.EQ.0 ) THEN + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, + $ SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 90 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 90 CONTINUE + SCALE = SCALE*SCALOC + END IF + ELSE + CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM, + $ RDSCAL, IPIV, JPIV ) + END IF +* +* Unpack solution vector(s) +* + K = 1 + II = MB*NB + 1 + DO 100 JJ = 0, NB - 1 + CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) + CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) + K = K + MB + II = II + MB + 100 CONTINUE +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( I.GT.1 ) THEN + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, + $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE, + $ C( 1, JS ), LDC ) + CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE, + $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE, + $ F( 1, JS ), LDF ) + END IF + IF( J.LT.Q ) THEN + K = MB*NB + 1 + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), + $ MB, B( JS, JE+1 ), LDB, ONE, + $ C( IS, JE+1 ), LDC ) + CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ), + $ MB, E( JS, JE+1 ), LDE, ONE, + $ F( IS, JE+1 ), LDF ) + END IF +* + END IF +* + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Solve (I, J) - subsystem +* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) +* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) +* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 +* + SCALE = ONE + SCALOC = ONE + DO 200 I = 1, P +* + IS = IWORK( I ) + ISP1 = IS + 1 + IE = IWORK( I+1 ) - 1 + MB = IE - IS + 1 + DO 190 J = Q, P + 2, -1 +* + JS = IWORK( J ) + JSP1 = JS + 1 + JE = IWORK( J+1 ) - 1 + NB = JE - JS + 1 + ZDIM = MB*NB*2 + IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 2-by-2 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = -B( JS, JS ) + Z( 1, 2 ) = D( IS, IS ) + Z( 2, 2 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = F( IS, JS ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 130 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 130 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + F( IS, JS ) = RHS( 2 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + ALPHA = RHS( 1 ) + CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ), + $ LDF ) + ALPHA = RHS( 2 ) + CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ), + $ LDF ) + END IF + IF( I.LT.P ) THEN + ALPHA = -RHS( 1 ) + CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA, + $ C( IE+1, JS ), 1 ) + ALPHA = -RHS( 2 ) + CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD, + $ C( IE+1, JS ), 1 ) + END IF +* + ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build a 4-by-4 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = ZERO + Z( 3, 1 ) = -B( JS, JS ) + Z( 4, 1 ) = -B( JSP1, JS ) +* + Z( 1, 2 ) = ZERO + Z( 2, 2 ) = A( IS, IS ) + Z( 3, 2 ) = -B( JS, JSP1 ) + Z( 4, 2 ) = -B( JSP1, JSP1 ) +* + Z( 1, 3 ) = D( IS, IS ) + Z( 2, 3 ) = ZERO + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = D( IS, IS ) + Z( 3, 4 ) = -E( JS, JSP1 ) + Z( 4, 4 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( IS, JSP1 ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( IS, JSP1 ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 140 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 140 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( IS, JSP1 ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( IS, JSP1 ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1, + $ F( IS, 1 ), LDF ) + CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1, + $ F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA, + $ RHS( 1 ), 1, C( IE+1, JS ), LDC ) + CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD, + $ RHS( 3 ), 1, C( IE+1, JS ), LDC ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN +* +* Build a 4-by-4 system Z' * x = RHS +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( IS, ISP1 ) + Z( 3, 1 ) = -B( JS, JS ) + Z( 4, 1 ) = ZERO +* + Z( 1, 2 ) = A( ISP1, IS ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 3, 2 ) = ZERO + Z( 4, 2 ) = -B( JS, JS ) +* + Z( 1, 3 ) = D( IS, IS ) + Z( 2, 3 ) = D( IS, ISP1 ) + Z( 3, 3 ) = -E( JS, JS ) + Z( 4, 3 ) = ZERO +* + Z( 1, 4 ) = ZERO + Z( 2, 4 ) = D( ISP1, ISP1 ) + Z( 3, 4 ) = ZERO + Z( 4, 4 ) = -E( JS, JS ) +* +* Set up right hand side(s) +* + RHS( 1 ) = C( IS, JS ) + RHS( 2 ) = C( ISP1, JS ) + RHS( 3 ) = F( IS, JS ) + RHS( 4 ) = F( ISP1, JS ) +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 150 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 150 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + C( IS, JS ) = RHS( 1 ) + C( ISP1, JS ) = RHS( 2 ) + F( IS, JS ) = RHS( 3 ) + F( ISP1, JS ) = RHS( 4 ) +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ), + $ 1, F( IS, 1 ), LDF ) + CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ), + $ 1, F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ), + $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ), + $ 1 ) + CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ), + $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ), + $ 1 ) + END IF +* + ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN +* +* Build an 8-by-8 system Z' * x = RHS +* + CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ ) +* + Z( 1, 1 ) = A( IS, IS ) + Z( 2, 1 ) = A( IS, ISP1 ) + Z( 5, 1 ) = -B( JS, JS ) + Z( 7, 1 ) = -B( JSP1, JS ) +* + Z( 1, 2 ) = A( ISP1, IS ) + Z( 2, 2 ) = A( ISP1, ISP1 ) + Z( 6, 2 ) = -B( JS, JS ) + Z( 8, 2 ) = -B( JSP1, JS ) +* + Z( 3, 3 ) = A( IS, IS ) + Z( 4, 3 ) = A( IS, ISP1 ) + Z( 5, 3 ) = -B( JS, JSP1 ) + Z( 7, 3 ) = -B( JSP1, JSP1 ) +* + Z( 3, 4 ) = A( ISP1, IS ) + Z( 4, 4 ) = A( ISP1, ISP1 ) + Z( 6, 4 ) = -B( JS, JSP1 ) + Z( 8, 4 ) = -B( JSP1, JSP1 ) +* + Z( 1, 5 ) = D( IS, IS ) + Z( 2, 5 ) = D( IS, ISP1 ) + Z( 5, 5 ) = -E( JS, JS ) +* + Z( 2, 6 ) = D( ISP1, ISP1 ) + Z( 6, 6 ) = -E( JS, JS ) +* + Z( 3, 7 ) = D( IS, IS ) + Z( 4, 7 ) = D( IS, ISP1 ) + Z( 5, 7 ) = -E( JS, JSP1 ) + Z( 7, 7 ) = -E( JSP1, JSP1 ) +* + Z( 4, 8 ) = D( ISP1, ISP1 ) + Z( 6, 8 ) = -E( JS, JSP1 ) + Z( 8, 8 ) = -E( JSP1, JSP1 ) +* +* Set up right hand side(s) +* + K = 1 + II = MB*NB + 1 + DO 160 JJ = 0, NB - 1 + CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 ) + CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 ) + K = K + MB + II = II + MB + 160 CONTINUE +* +* +* Solve Z' * x = RHS +* + CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR ) + IF( IERR.GT.0 ) + $ INFO = IERR +* + CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC ) + IF( SCALOC.NE.ONE ) THEN + DO 170 K = 1, N + CALL DSCAL( M, SCALOC, C( 1, K ), 1 ) + CALL DSCAL( M, SCALOC, F( 1, K ), 1 ) + 170 CONTINUE + SCALE = SCALE*SCALOC + END IF +* +* Unpack solution vector(s) +* + K = 1 + II = MB*NB + 1 + DO 180 JJ = 0, NB - 1 + CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 ) + CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 ) + K = K + MB + II = II + MB + 180 CONTINUE +* +* Substitute R(I, J) and L(I, J) into remaining +* equation. +* + IF( J.GT.P+2 ) THEN + CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, + $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE, + $ F( IS, 1 ), LDF ) + CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, + $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE, + $ F( IS, 1 ), LDF ) + END IF + IF( I.LT.P ) THEN + CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, + $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, + $ ONE, C( IE+1, JS ), LDC ) + CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE, + $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, + $ ONE, C( IE+1, JS ), LDC ) + END IF +* + END IF +* + 190 CONTINUE + 200 CONTINUE +* + END IF + RETURN +* +* End of DTGSY2 +* + END diff --git a/mex/sources/libslicot/readme b/mex/sources/libslicot/readme new file mode 100644 index 000000000..85f5bce37 --- /dev/null +++ b/mex/sources/libslicot/readme @@ -0,0 +1,8 @@ +SLICOT Library Subdirectory src +------------------------------- + +SLICOT Library Subdirectory src contains all source files of the +SLICOT Library routines. The codes follow the Fortran 77 language +conventions. SLICOT routines make calls to the state-of-the-art +packages LAPACK (Linear Algebra Package) and BLAS (Basic Linear +Algebra Subprograms). diff --git a/mex/sources/libslicot/select.f b/mex/sources/libslicot/select.f new file mode 100644 index 000000000..dd3e62baf --- /dev/null +++ b/mex/sources/libslicot/select.f @@ -0,0 +1,27 @@ + LOGICAL FUNCTION SELECT( PAR1, PAR2 ) +C +C SLICOT RELEASE 5.0. +C +C Copyright (c) 2002-2009 NICONET e.V. +C +C This program is free software: you can redistribute it and/or +C modify it under the terms of the GNU General Public License as +C published by the Free Software Foundation, either version 2 of +C the License, or (at your option) any later version. +C +C This program is distributed in the hope that it will be useful, +C but WITHOUT ANY WARRANTY; without even the implied warranty of +C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +C GNU General Public License for more details. +C +C You should have received a copy of the GNU General Public License +C along with this program. If not, see +C . +C +C Void logical function for DGEES. +C + DOUBLE PRECISION PAR1, PAR2 +C + SELECT = .TRUE. + RETURN + END